From gitlab at gitlab.haskell.org Mon May 1 02:46:11 2023 From: gitlab at gitlab.haskell.org (Moritz Angermann (@angerman)) Date: Sun, 30 Apr 2023 22:46:11 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/angerman/riscv64-ncg Message-ID: <644f27f3ed429_178e7414aaf06e02410790@gitlab.mail> Moritz Angermann pushed new branch wip/angerman/riscv64-ncg at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/angerman/riscv64-ncg You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 02:52:00 2023 From: gitlab at gitlab.haskell.org (Moritz Angermann (@angerman)) Date: Sun, 30 Apr 2023 22:52:00 -0400 Subject: [Git][ghc/ghc][wip/angerman/riscv64-ncg] 3 commits: Bring back old aarch64 test-suite Message-ID: <644f29506ecd1_178e7414ac4205c24109c0@gitlab.mail> Moritz Angermann pushed to branch wip/angerman/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: 304ed098 by Moritz Angermann at 2023-05-01T02:51:27+00:00 Bring back old aarch64 test-suite - - - - - 25dbbe54 by Moritz Angermann at 2023-05-01T02:51:38+00:00 Add RV64 backend - - - - - 80e8e802 by Moritz Angermann at 2023-05-01T02:51:43+00:00 Add RV64 notes - - - - - 9 changed files: - compiler/CodeGen.Platform.h - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/CmmToAsm.hs - compiler/GHC/CmmToAsm/PIC.hs - + compiler/GHC/CmmToAsm/RV64-notes.md - + compiler/GHC/CmmToAsm/RV64.hs - + compiler/GHC/CmmToAsm/RV64/CodeGen.hs - + compiler/GHC/CmmToAsm/RV64/Cond.hs - + compiler/GHC/CmmToAsm/RV64/Instr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b462363660a280754e11a81778bc6bb29496d763...80e8e802a98ab15967f78e66ee312e357ce383d7 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b462363660a280754e11a81778bc6bb29496d763...80e8e802a98ab15967f78e66ee312e357ce383d7 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 06:43:59 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Mon, 01 May 2023 02:43:59 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] 18 commits: DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) Message-ID: <644f5fafc9f9e_178e7414e9365e4242966f@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 910740bb by Josh Meredith at 2023-05-01T06:42:22+00:00 WIP refactor jsSaturate to return a saturated IR - - - - - 30 changed files: - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Hs.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Names.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/Stg/Lift.hs - compiler/GHC/Stg/Lift/Analysis.hs - compiler/GHC/Stg/Lift/Monad.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Stats.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/117fc799b5caa7280526fbcc5cdf523dfb7a57ce...910740bb10a82bc2e95af042bbbf6ba6376e61f3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/117fc799b5caa7280526fbcc5cdf523dfb7a57ce...910740bb10a82bc2e95af042bbbf6ba6376e61f3 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 06:50:24 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Mon, 01 May 2023 02:50:24 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated IR (#23328) Message-ID: <644f61303a817_178e7414ec2cbcc24316bf@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 56208ad0 by Josh Meredith at 2023-05-01T06:49:56+00:00 JS: refactor jsSaturate to return a saturated IR (#23328) - - - - - 6 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -22,7 +22,6 @@ module GHC.JS.Transform , composOpM_ , composOpFold , satJExpr - , satJStat ) where @@ -200,8 +199,8 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) +jsSaturate' :: (JMacro a) => Maybe FastString -> a -> a +jsSaturate' str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) jsSaturate_ :: (JMacro a) => a -> IdentSupply a jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) @@ -219,9 +218,9 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) -- -- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing +jsSaturate :: Maybe FastString -> JStat -> Sat.JStat +jsSaturate str = witness . proof str + where proof = jsSaturate' -- This is an Applicative but we can't use it because no type variables :( witness :: JStat -> Sat.JStat @@ -315,5 +314,5 @@ satJVal = go go (JStr f) = Sat.JStr f go (JRegEx f) = Sat.JRegEx f go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) + go (JFunc args body) = Sat.JFunc args (jsSaturate Nothing body) go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a +saturateFFI :: Int -> JStat -> Sat.JStat saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat +rtsDecls :: Sat.JStat rtsDecls = jsSaturate (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread @@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat +rts :: StgToJSConfig -> Sat.JStat rts = jsSaturate (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56208ad05b5fe4d26821652bf3564fdb51307b39 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56208ad05b5fe4d26821652bf3564fdb51307b39 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 07:27:36 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Mon, 01 May 2023 03:27:36 -0400 Subject: [Git][ghc/ghc][wip/expand-do] PopSrcSpan in HsExpr Message-ID: <644f69e8c7705_178e7414f3407b024357c4@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 370f8052 by Apoorv Ingle at 2023-05-01T02:26:54-05:00 PopSrcSpan in HsExpr - - - - - 10 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Utils/Zonk.hs - compiler/Language/Haskell/Syntax/Expr.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -726,6 +726,12 @@ ppr_expr (XExpr x) = case ghcPass @p of GhcRn -> ppr x GhcTc -> ppr x +ppr_expr (PopSrcSpan x) = case ghcPass @p of + GhcPs -> panic "ppr_expr Ps HsPopSrcSpan" + GhcRn -> ppr x + GhcTc -> panic "ppr_expr Tc HsPopSrcSpan" + + instance Outputable XXExprGhcTc where ppr (WrapExpr (HsWrap co_fn e)) = pprHsWrapper co_fn (\_parens -> pprExpr e) @@ -845,6 +851,7 @@ hsExprNeedsParens prec = go go (HsDo _ sc _) | isDoComprehensionContext sc = False | otherwise = prec > topPrec + go (PopSrcSpan{}) = prec > topPrec go (ExplicitList{}) = False go (RecordUpd{}) = False go (ExprWithTySig{}) = prec >= sigPrec @@ -1107,9 +1114,9 @@ data HsExpansion orig expanded -- | Just print the original expression (the @a@) with the expanded version (the @b@) instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ppr (HsExpanded orig expanded) - -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - -- (ppr orig) - = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) + = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) + (ppr orig) + -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) {- ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -114,6 +114,7 @@ hsExprType (HsIf _ _ t _) = lhsExprType t hsExprType (HsMultiIf ty _) = ty hsExprType (HsLet _ _ _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty +hsExprType (PopSrcSpan expr) = pprPanic "hsExprType" (text "impossible happened PopSrcSpan" <+> ppr expr) hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr hsExprType (RecordUpd v _ _) = dataConCantHappen v ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -29,6 +29,7 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) +import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name @@ -258,6 +259,8 @@ dsExpr (HsOverLit _ lit) = do { warnAboutOverflowedOverLit lit ; dsOverLit lit } +dsExpr e@(PopSrcSpan {}) = pprPanic "dsExpr" (ppr e) + dsExpr e@(XExpr ext_expr_tc) = case ext_expr_tc of ExpansionExpr (HsExpanded _ b) -> dsExpr b @@ -857,15 +860,22 @@ warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM () warnUnusedBindValue fun arg arg_ty | Just (SrcSpanAnn _ l, f) <- fish_var fun , is_gen_then f - , isNoSrcSpan l - = warnDiscardedDoBindings arg arg_ty + -- , isNoSrcSpan l + = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun + , text "arg" <+> ppr arg + , text "arg_ty" <+> ppr arg_ty + , text "f" <+> ppr f <+> ppr (is_gen_then f) + , text "l" <+> ppr (isNoSrcSpan l)]) + warnDiscardedDoBindings arg arg_ty where -- retrieve the location info and the head of the application fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc) fish_var (L l (HsVar _ id)) = return (l, id) + fish_var (L _ (PopSrcSpan e)) = pprPanic "warnUnusedBindValue" (ppr e) fish_var (L _ (HsAppType _ e _ _)) = fish_var e fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e) return (l, e') + fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e) fish_var _ = Nothing -- is this id a compiler generated (>>) with expanded do ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1663,7 +1663,7 @@ repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e) repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e) repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e) repE e@(HsProc{}) = notHandled (ThExpressionForm e) - +repE e@(PopSrcSpan{}) = notHandled (ThExpressionForm e) {- Note [Quotation and rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1234,6 +1234,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where ] HsGetField {} -> [] HsProjection {} -> [] + PopSrcSpan {} -> [] XExpr x | HieTc <- hiePass @p -> case x of ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -560,6 +560,8 @@ rnExpr (ArithSeq _ _ seq) else return (ArithSeq noExtField Nothing new_seq, fvs) } +rnExpr (PopSrcSpan _) = panic "impossible happened rnExpr PopSrcSpan" + {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -408,9 +408,33 @@ tcExpr (HsMultiIf _ alts) res_ty ; return (HsMultiIf res_ty alts') } where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } +tcExpr (HsDo _ doFlav@(DoExpr{}) (L loc stmts)) res_ty + = do { expand_expr <- expandDoStmts doFlav stmts + ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doFlav (L loc stmts)) + (unLoc expand_expr) + -- Do expansion on the fly + ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr + , text "expanded:" <+> ppr expand_expr + ]) + ; tcExpr expand_do_expr res_ty + } + +tcExpr (HsDo _ doFlav@(MDoExpr{}) (L loc stmts)) res_ty + = do { expand_expr <- expandDoStmts doFlav stmts + ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doFlav (L loc stmts)) + (unLoc expand_expr) + -- Do expansion on the fly + ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr + , text "expanded:" <+> ppr expand_expr + ]) + ; tcExpr expand_do_expr res_ty + } + tcExpr (HsDo _ do_or_lc stmts) res_ty = tcDoStmts do_or_lc stmts res_ty +tcExpr (PopSrcSpan (L _ expr)) res_ty = popErrCtxt $ tcExpr expr res_ty + tcExpr (HsProc x pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Tc.Gen.Match , tcDoStmt , tcGuardStmt , checkArgCounts + , expandDoStmts ) where @@ -319,32 +320,34 @@ tcDoStmts ListComp (L l stmts) res_ty (mkCheckExpType elt_ty) ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } -tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty - = do { -- stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty +tcDoStmts (DoExpr _) ss _ + = pprPanic "tcDoStmts DoExpr" (ppr ss) -- do { + -- stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty -- ; res_ty <- readExpType res_ty -- ; return (HsDo res_ty doExpr (L l stmts')) - expand_expr <- expand_do_stmts doExpr stmts - ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doExpr (L l stmts)) - (unLoc expand_expr) - -- Do expansion on the fly - ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr - , text "expanded:" <+> ppr expand_expr - ]) - ; tcExpr expand_do_expr res_ty - } - -tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty - = do { -- stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty - -- ; res_ty <- readExpType res_ty + -- expand_expr <- expand_do_stmts doExpr stmts + -- ; let expand_do_expr = mkExpandedExpr (HsDo noExtField doExpr (L l stmts)) + -- (unLoc expand_expr) + -- -- Do expansion on the fly + -- ; traceTc "tcDoStmts do" (vcat [ text "original:" <+> ppr expand_do_expr + -- , text "expanded:" <+> ppr expand_expr + -- ]) + -- ; tcExpr expand_do_expr res_ty + -- } + +tcDoStmts (MDoExpr _) ss _ + = pprPanic "tcDoStmts MDoExpr" (ppr ss) + --do { -- stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty + -- ; res_ty <- readExpType res_ty -- ; return (HsDo res_ty mDoExpr (L l stmts')) - expand_expr <- expand_do_stmts mDoExpr stmts - ; let expand_do_expr = mkExpandedExpr (HsDo noExtField mDoExpr (L l stmts)) - (unLoc expand_expr) - -- Do expansion on the fly - ; traceTc "tcDoStmts mdo" (text "tcExpr:" <+> ppr expand_do_expr) - ; tcExpr expand_do_expr res_ty + -- expand_expr <- expand_do_stmts mDoExpr stmts + -- ; let expand_do_expr = mkExpandedExpr (HsDo noExtField mDoExpr (L l stmts)) + -- (unLoc expand_expr) + -- -- Do expansion on the fly + -- ; traceTc "tcDoStmts mdo" (text "tcExpr:" <+> ppr expand_do_expr) + -- ; tcExpr expand_do_expr res_ty - } + -- } tcDoStmts MonadComp (L l stmts) res_ty = do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty @@ -1201,6 +1204,9 @@ checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) }) * * ************************************************************************ -} +expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn) +expandDoStmts = expand_do_stmts + -- | Expand the Do statments so that it works fine with Quicklook -- See Note[Rebindable Do and Expanding Statements] -- ANI Questions: 1. What should be the location information in the expanded expression? @@ -1230,7 +1236,9 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts) | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn , fail_op <- xbsrn_failOp xbsrn = -- the pattern binding x can fail --- stmts ~~> stmt' let f pat = stmts'; f _ = fail ".." +-- instead of making an internal name, the fail block is just an anonymous match block +-- stmts ~~> stmt' let / = stmts'; +-- _ = fail ".."; -- ------------------------------------------------------- -- pat <- e ; stmts ~~> (>>=) e f do expand_stmts <- expand_do_stmts do_or_lc lstmts @@ -1248,7 +1256,7 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts) expand_stmts <- expand_do_stmts do_or_lc lstmts return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=) [ e - , mkHsLam [pat] expand_stmts -- (\ x -> stmts') + , mkHsLam [pat] (noLocA $ PopSrcSpan expand_stmts) -- (\ x -> stmts') ] expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) = @@ -1265,9 +1273,9 @@ expand_do_stmts do_or_lc ((L _ (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) = -- ---------------------------------------------- -- e ; stmts ~~> (>>) e stmts' do expand_stmts <- expand_do_stmts do_or_lc lstmts - return $ mkHsApps (wrapGenSpan f) -- (>>) - [ e -- e - , expand_stmts ] -- stmts' + return $ noLocA (PopSrcSpan (mkHsApps (wrapGenSpan f) -- (>>) + [ e -- e + , expand_stmts ])) -- stmts' expand_do_stmts do_or_lc ((L _ (RecStmt { recS_stmts = rec_stmts @@ -1288,11 +1296,11 @@ expand_do_stmts do_or_lc -- ; return (local_only_ids ++ later_ids) } )) -- (\ [ local_only_ids ++ later_ids ] -> stmts') do expand_stmts <- expand_do_stmts do_or_lc lstmts - return $ (mkHsApps (genLHsVar bindMName) -- (Prelude.>>=) - [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block)) - , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x -> - expand_stmts -- stmts') - ]) + return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=) + [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block)) + , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x -> + (noLocA $ PopSrcSpan expand_stmts) -- stmts') + ] where local_only_ids = local_ids \\ later_ids -- get unique local rec ids; --local rec ids and later ids can overlap @@ -1376,9 +1384,12 @@ mk_failable_lexpr_tcm pat lexpr fail_op = do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation) PatBindRhs pat $ return id -- whatever ; dflags <- getDynFlags + ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr tc_pat + , ppr $ isIrrefutableHsPat dflags tc_pat + , ppr $ isPatSynCon (unLoc tc_pat)]) ; if isIrrefutableHsPat dflags tc_pat -- don't decorate with fail statement if the pattern is irrefutable || (isPatSynCon (unLoc tc_pat)) -- pattern syns always get a fail block while desugaring so skip - then return $ mkHsLam [pat] lexpr + then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } where isPatSynCon (ConPat {pat_con = L _ (PatSynCon _)}) = True @@ -1391,7 +1402,7 @@ mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsEx mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) = do dflags <- getDynFlags return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \ - (noLocA [ mkHsCaseAlt pat lexpr -- pat -> expr + (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) -- pat -> expr , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern" (noLocA $ genHsApp fail_op (mk_fail_msg_expr dflags (DoExpr Nothing) pat)) ===================================== compiler/GHC/Tc/Utils/Zonk.hs ===================================== @@ -846,6 +846,8 @@ zonkExpr env (HsDo ty do_or_lc (L l stmts)) new_ty <- zonkTcTypeToTypeX env ty return (HsDo new_ty do_or_lc (L l new_stmts)) +zonkExpr env (PopSrcSpan (L _ exp)) = zonkExpr env exp + zonkExpr env (ExplicitList ty exprs) = do new_ty <- zonkTcTypeToTypeX env ty new_exprs <- zonkLExprs env exprs ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -584,6 +584,11 @@ data HsExpr p -- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr -- for an example of how we use it. + | PopSrcSpan (LHsExpr p) + -- Placeholder for identifying generated source locations in GhcRn phase + -- Should not presist post typechecking + -- Note [Desugaring Do with HsExpansion] TODO + -- --------------------------------------------------------------------- data DotFieldOcc p View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/370f8052b58945d7d7c4917c89728fe6bab92660 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/370f8052b58945d7d7c4917c89728fe6bab92660 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 07:49:05 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Mon, 01 May 2023 03:49:05 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <644f6ef1f1295_178e7414fd1b168244477e@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 13bc0c96 by Josh Meredith at 2023-05-01T07:48:30+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 6 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -22,7 +22,6 @@ module GHC.JS.Transform , composOpM_ , composOpFold , satJExpr - , satJStat ) where @@ -200,8 +199,8 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) +jsSaturate' :: (JMacro a) => Maybe FastString -> a -> a +jsSaturate' str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) jsSaturate_ :: (JMacro a) => a -> IdentSupply a jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) @@ -219,9 +218,9 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) -- -- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing +jsSaturate :: Maybe FastString -> JStat -> Sat.JStat +jsSaturate str = witness . proof str + where proof = jsSaturate' -- This is an Applicative but we can't use it because no type variables :( witness :: JStat -> Sat.JStat @@ -315,5 +314,5 @@ satJVal = go go (JStr f) = Sat.JStr f go (JRegEx f) = Sat.JRegEx f go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) + go (JFunc args body) = Sat.JFunc args (jsSaturate Nothing body) go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a +saturateFFI :: Int -> JStat -> Sat.JStat saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat +rtsDecls :: Sat.JStat rtsDecls = jsSaturate (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread @@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat +rts :: StgToJSConfig -> Sat.JStat rts = jsSaturate (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13bc0c9601f46c345ed5d5cc911d6a153c4213f1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13bc0c9601f46c345ed5d5cc911d6a153c4213f1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 08:40:05 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Mon, 01 May 2023 04:40:05 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <644f7ae5b9b02_178e74150829e88245224a@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 24d527f4 by Josh Meredith at 2023-05-01T08:39:50+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 6 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -22,7 +22,6 @@ module GHC.JS.Transform , composOpM_ , composOpFold , satJExpr - , satJStat ) where @@ -200,8 +199,8 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) +jsSaturate' :: (JMacro a) => Maybe FastString -> a -> a +jsSaturate' str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) jsSaturate_ :: (JMacro a) => a -> IdentSupply a jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) @@ -219,9 +218,9 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) -- -- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing +jsSaturate :: Maybe FastString -> JStat -> Sat.JStat +jsSaturate str = witness . proof str + where proof = jsSaturate' -- This is an Applicative but we can't use it because no type variables :( witness :: JStat -> Sat.JStat @@ -315,5 +314,5 @@ satJVal = go go (JStr f) = Sat.JStr f go (JRegEx f) = Sat.JRegEx f go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) + go (JFunc args body) = Sat.JFunc args (jsSaturate Nothing body) go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a +saturateFFI :: Int -> JStat -> Sat.JStat saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) @@ -180,4 +181,4 @@ globalOccs jst = do let g = GlobalOcc i gid 1 in go (addToUFM_C inc gids i g) is - pure $ go emptyUFM (identsS $ satJStat jst) + pure $ go emptyUFM (identsS jst) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat +rtsDecls :: Sat.JStat rtsDecls = jsSaturate (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread @@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat +rts :: StgToJSConfig -> Sat.JStat rts = jsSaturate (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24d527f470b0533ed3618e8094f0d0a512b2a291 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24d527f470b0533ed3618e8094f0d0a512b2a291 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 09:58:35 2023 From: gitlab at gitlab.haskell.org (Moritz Angermann (@angerman)) Date: Mon, 01 May 2023 05:58:35 -0400 Subject: [Git][ghc/ghc][wip/angerman/riscv64-ncg] Fixup Rebase mistake Message-ID: <644f8d4b48de_178e74151eb9af424670d0@gitlab.mail> Moritz Angermann pushed to branch wip/angerman/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: 30a10abc by Moritz Angermann at 2023-05-01T09:53:15+00:00 Fixup Rebase mistake - - - - - 1 changed file: - compiler/GHC/CmmToAsm/Reg/Linear.hs Changes: ===================================== compiler/GHC/CmmToAsm/Reg/Linear.hs ===================================== @@ -114,7 +114,7 @@ import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 -import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as RV64 +import qualified GHC.CmmToAsm.Reg.Linear.RV64 as RV64 import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Utils View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30a10abcc56166885fc457f55a66acbeddae06cd -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/30a10abcc56166885fc457f55a66acbeddae06cd You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 10:28:41 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 01 May 2023 06:28:41 -0400 Subject: [Git][ghc/ghc][wip/T23146] Update Note [Core letrec invariant] Message-ID: <644f94599b29c_178e741527a5cd0247428b@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: b7784859 by Rodrigo Mesquita at 2023-05-01T11:28:15+01:00 Update Note [Core letrec invariant] Authored by @simonpj - - - - - 1 changed file: - compiler/GHC/Core.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -368,18 +368,36 @@ Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Core letrec invariant: - The right hand sides of all - /top-level/ or /recursive/ - bindings must be of lifted type - - There is one exception to this rule, top-level @let at s are - allowed to bind primitive string literals: see - Note [Core top-level string literals]. + The right hand sides of all /top-level/ or /recursive/ + bindings must be of lifted type See "Type#type_classification" in GHC.Core.Type -for the meaning of "lifted" vs. "unlifted"). - -For the non-top-level, non-recursive case see Note [Core let-can-float invariant]. +for the meaning of "lifted" vs. "unlifted". + +For the non-top-level, non-recursive case see +Note [Core let-can-float invariant]. + +At top level, however, there are two exceptions to this rule: + +(TL1) A top-level binding is allowed to bind primitive string literal, + (which is unlifted). See Note [Core top-level string literals]. + +(TL2) In CorePrep, we generate a top-level binding for every data constructor + e.g. data T = MkT Int + we generate + MkT :: Int -> T + MkT = \x. MkT x + (This binding looks recursive, but isn't; it defines a top-level, curried + function whose body just allocates and returns the data constructor.) + + But if (a) the data contructor is nullary and (b) the data type is unlifted, + this binding is unlifted. + e.g. data S :: UnliftedType where { S1 :: S, S2 :: S -> S } + we generate + S1 :: S -- A top-level unlifted binding + S1 = S1 + We allow this top-level unlifted binding to exist, after CorePrep + only. Note [Core let-can-float invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b7784859d190e75b8fe52df002c0b615c88f0365 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b7784859d190e75b8fe52df002c0b615c88f0365 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 14:37:26 2023 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Mon, 01 May 2023 10:37:26 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/t23315 Message-ID: <644fcea6cb590_178e74156a6aa9825217ea@gitlab.mail> Finley McIlwaine pushed new branch wip/t23315 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/t23315 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 14:38:46 2023 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Mon, 01 May 2023 10:38:46 -0400 Subject: [Git][ghc/ghc][wip/t23315] Insert documentation into parsed signature modules Message-ID: <644fcef64a1ff_178e74156a6bc2c2521957@gitlab.mail> Finley McIlwaine pushed to branch wip/t23315 at Glasgow Haskell Compiler / GHC Commits: 83f26064 by Finley McIlwaine at 2023-05-01T08:38:22-06:00 Insert documentation into parsed signature modules Causes haddock comments in signature modules to be properly inserted into the AST (just as they are for regular modules) if the `-haddock` flag is given. Also adds a test that compares `-ddump-parsed-ast` output for a signature module to prevent further regressions. Fixes #23315 - - - - - 7 changed files: - compiler/GHC/Parser.y - + testsuite/tests/parser/should_compile/T23315/Makefile - + testsuite/tests/parser/should_compile/T23315/Setup.hs - + testsuite/tests/parser/should_compile/T23315/T23315.cabal - + testsuite/tests/parser/should_compile/T23315/T23315.hsig - + testsuite/tests/parser/should_compile/T23315/T23315.stderr - + testsuite/tests/parser/should_compile/T23315/all.T Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -743,7 +743,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } -- Exported parsers %name parseModuleNoHaddock module -%name parseSignature signature +%name parseSignatureNoHaddock signature %name parseImport importdecl %name parseStatement e_stmt %name parseDeclaration topdecl @@ -4376,18 +4376,29 @@ pvL :: MonadP m => m (LocatedAn t a) -> m (Located a) pvL a = do { av <- a ; return (reLoc av) } --- | Parse a Haskell module with Haddock comments. --- This is done in two steps: +-- | Parse a Haskell module with Haddock comments. This is done in two steps: -- -- * 'parseModuleNoHaddock' to build the AST -- * 'addHaddockToModule' to insert Haddock comments into it -- --- This is the only parser entry point that deals with Haddock comments. --- The other entry points ('parseDeclaration', 'parseExpression', etc) do --- not insert them into the AST. +-- This and the signature module parser are the only parser entry points that +-- deal with Haddock comments. The other entry points ('parseDeclaration', +-- 'parseExpression', etc) do not insert them into the AST. parseModule :: P (Located (HsModule GhcPs)) parseModule = parseModuleNoHaddock >>= addHaddockToModule +-- | Parse a Haskell signature module with Haddock comments. This is done in two +-- steps: +-- +-- * 'parseSignatureNoHaddock' to build the AST +-- * 'addHaddockToModule' to insert Haddock comments into it +-- +-- This and the module parser are the only parser entry points that deal with +-- Haddock comments. The other entry points ('parseDeclaration', +-- 'parseExpression', etc) do not insert them into the AST. +parseSignature :: P (Located (HsModule GhcPs)) +parseSignature = parseSignatureNoHaddock >>= addHaddockToModule + commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann) commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc ===================================== testsuite/tests/parser/should_compile/T23315/Makefile ===================================== @@ -0,0 +1,18 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP = ./Setup -v0 + +T23315: clean + $(MAKE) clean + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup + $(SETUP) clean + $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' + $(SETUP) build 1>&2 +ifneq "$(CLEANUP)" "" + $(MAKE) clean +endif + +clean : + $(RM) -r */dist Setup$(exeext) *.o *.hi ===================================== testsuite/tests/parser/should_compile/T23315/Setup.hs ===================================== @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain \ No newline at end of file ===================================== testsuite/tests/parser/should_compile/T23315/T23315.cabal ===================================== @@ -0,0 +1,10 @@ +name: T23315 +version: 0.1.0.0 +build-type: Simple +cabal-version: 2.0 + +library + signatures: T23315 + build-depends: base >= 4.3 && < 5 + default-language: Haskell2010 + ghc-options: -Wall -haddock -ddump-parsed-ast ===================================== testsuite/tests/parser/should_compile/T23315/T23315.hsig ===================================== @@ -0,0 +1,4 @@ +signature T23315 where +-- | My unit +a :: () +-- ^ More docs ===================================== testsuite/tests/parser/should_compile/T23315/T23315.stderr ===================================== @@ -0,0 +1,117 @@ + +==================== Parser AST ==================== + +(L + { T23315.hsig:1:1 } + (HsModule + (XModulePs + (EpAnn + (Anchor + { T23315.hsig:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddEpAnn AnnSignature (EpaSpan { T23315.hsig:1:1-9 })) + ,(AddEpAnn AnnWhere (EpaSpan { T23315.hsig:1:18-22 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + []) + (Nothing)) + (EpaComments + [])) + (VirtualBraces + (1)) + (Nothing) + (Nothing)) + (Just + (L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:1:11-16 }) + {ModuleName: T23315})) + (Nothing) + [] + [(L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:2:1-12 }) + (DocD + (NoExtField) + (DocCommentNext + (L + { T23315.hsig:2:1-12 } + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringNext) + (:| + (L + { T23315.hsig:2:5-12 } + (HsDocStringChunk + " My unit")) + [])) + []))))) + ,(L + (SrcSpanAnn (EpAnn + (Anchor + { T23315.hsig:3:1-7 } + (UnchangedAnchor)) + (AnnListItem + []) + (EpaComments + [])) { T23315.hsig:3:1-7 }) + (SigD + (NoExtField) + (TypeSig + (EpAnn + (Anchor + { T23315.hsig:3:1 } + (UnchangedAnchor)) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T23315.hsig:3:3-4 })) + []) + (EpaComments + [])) + [(L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:1 }) + (Unqual + {OccName: a}))] + (HsWC + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:6-7 }) + (HsSig + (NoExtField) + (HsOuterImplicit + (NoExtField)) + (L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:6-7 }) + (HsTupleTy + (EpAnn + (Anchor + { T23315.hsig:3:6 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (EpaSpan { T23315.hsig:3:6 }) + (EpaSpan { T23315.hsig:3:7 })) + (EpaComments + [])) + (HsBoxedOrConstraintTuple) + [])))))))) + ,(L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:4:1-14 }) + (DocD + (NoExtField) + (DocCommentPrev + (L + { T23315.hsig:4:1-14 } + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringPrevious) + (:| + (L + { T23315.hsig:4:5-14 } + (HsDocStringChunk + " More docs")) + [])) + [])))))])) + + ===================================== testsuite/tests/parser/should_compile/T23315/all.T ===================================== @@ -0,0 +1,3 @@ +test('T23315', + [extra_files(['Setup.hs']), js_broken(22352)], + makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83f26064c4fbfa8ff2442d0f40fca8953d70446c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83f26064c4fbfa8ff2442d0f40fca8953d70446c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 15:59:28 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Mon, 01 May 2023 11:59:28 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/glossary Message-ID: <644fe1e043864_178e74157f4916c25324b0@gitlab.mail> Ben Gamari pushed new branch wip/glossary at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/glossary You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 16:12:23 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Mon, 01 May 2023 12:12:23 -0400 Subject: [Git][ghc/ghc][wip/glossary] Update glossary.rst Message-ID: <644fe4e76bb8f_178e74158405f0c2540843@gitlab.mail> Ben Gamari pushed to branch wip/glossary at Glasgow Haskell Compiler / GHC Commits: f5f79492 by Ben Gamari at 2023-05-01T16:12:22+00:00 Update glossary.rst - - - - - 1 changed file: - docs/users_guide/glossary.rst Changes: ===================================== docs/users_guide/glossary.rst ===================================== @@ -5,14 +5,8 @@ technology preview:: GHC will occassionally ship features advertised as being in a *technology preview* state. Such features are generally opt-in in nature (e.g. new - language extensions). - - - Expectation that work will continue -- unlikely to just disappear - Doesn’t implement all features (best to enumerate: TH…) - A list of known bugs/shortcomings listed here (wiki page) - Isn’t optimized (produces suboptimal code) - Behavior may change in the future, although we will try to document such changes - - - + language extensions) and may have various shortcomings. These may include + known bugs (which we will try to document), lacking optimisation, and + unhandled interactions with other language features. As such, behavior + of such features may change in the future. However, we do expect features + to converge to non-preview state over the course of a few GHC major releases. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5f79492db87a914fcc49d4886385b6f6a185c6a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5f79492db87a914fcc49d4886385b6f6a185c6a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 16:14:31 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 01 May 2023 12:14:31 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] 9 commits: JS: Fix h$base_access implementation (issue 22576) Message-ID: <644fe567b9e16_178e74158405f0c25412e0@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c7a9d2d6 by Ben Gamari at 2023-04-26T12:59:41+01:00 ghc-toolchain: Initial commit - - - - - e824e588 by Ben Gamari at 2023-04-26T12:59:41+01:00 configure: Rip out Solaris dyld check Solaris 11 was released over a decade ago and, moreover, I doubt we have any Solaris users - - - - - e3fdc932 by Ben Gamari at 2023-04-26T12:59:41+01:00 Move via-C flags into GHC - - - - - c2d3204f by Ben Gamari at 2023-04-26T12:59:41+01:00 Rip out runtime linker/compiler checks - - - - - e29638dc by Ben Gamari at 2023-04-26T12:59:41+01:00 configure: Rip out toolchain selection logic - - - - - 320ad3ec by Ben Gamari at 2023-04-26T12:59:41+01:00 Fixes - - - - - 11ecbac3 by Rodrigo Mesquita at 2023-05-01T17:11:41+01:00 Rename readProcess to readProcessStdout Fixes a bug regarding a translation from the autconf program that failed to account for the exit code. The longer name reenforces that we really only care about the stdout, and the exit code and stderr of the program are irrelevant for the case. - - - - - 30 changed files: - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Linker/ExtraObj.hs - compiler/GHC/Settings/IO.hs - compiler/GHC/SysTools/Info.hs - compiler/GHC/SysTools/Tasks.hs - configure.ac - distrib/configure.ac.in - docs/users_guide/exts/implicit_parameters.rst - hadrian/cfg/system.config.in - hadrian/src/Oracles/Flag.hs - hadrian/src/Settings/Builders/RunTest.hs - libraries/base/jsbits/base.js - − m4/check_for_gold_t22266.m4 - − m4/check_ld_copy_bug.m4 - − m4/find_ld.m4 - − m4/find_merge_objects.m4 - − m4/fp_find_nm.m4 - − m4/fp_gcc_extra_flags.m4 - − m4/fp_gcc_supports_no_pie.m4 - − m4/fp_gcc_version.m4 - − m4/fp_prog_ar.m4 - − m4/fp_prog_ar_args.m4 - − m4/fp_prog_ar_is_gnu.m4 - − m4/fp_prog_ar_needs_ranlib.m4 - − m4/fp_prog_ar_supports_atfile.m4 - − m4/fp_prog_ar_supports_dash_l.m4 - − m4/fp_prog_ld_filelist.m4 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1035f226e7297e1f51d0c0c89e280bfec6b4cb27...11ecbac333fe11acfefdcd45aa680045c2866452 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1035f226e7297e1f51d0c0c89e280bfec6b4cb27...11ecbac333fe11acfefdcd45aa680045c2866452 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 16:15:09 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 01 May 2023 12:15:09 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] ghc-toolchain: Rename readProcess to readProcessStdout Message-ID: <644fe58dc9ca3_178e7415853a47c254177d@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: 102ae4bc by Rodrigo Mesquita at 2023-05-01T17:14:57+01:00 ghc-toolchain: Rename readProcess to readProcessStdout Fixes a bug regarding a translation from the autconf program that failed to account for the exit code. The longer name reenforces that we really only care about the stdout, and the exit code and stderr of the program are irrelevant for the case. - - - - - 6 changed files: - utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs - utils/ghc-toolchain/src/GHC/Toolchain/Program.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs - utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs Changes: ===================================== utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs ===================================== @@ -96,7 +96,7 @@ checkLeadingUnderscore :: Cc -> Nm -> M Bool checkLeadingUnderscore cc nm = checking ctxt $ withTempDir $ \dir -> do let test_o = dir "test.o" compileC cc test_o prog - out <- readProgram (nmProgram nm) [test_o] + out <- readProgramStdout (nmProgram nm) [test_o] return $ "_func" `isInfixOf` out where prog = "int func(void) { return 0; }" ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Program.hs ===================================== @@ -6,6 +6,7 @@ module GHC.Toolchain.Program , runProgram , callProgram , readProgram + , readProgramStdout -- * Finding 'Program's , ProgOpt(..) , emptyProgOpt @@ -58,8 +59,16 @@ callProgram prog args = do , "Exited with code " ++ show n ] -readProgram :: Program -> [String] -> M String +-- | Runs a program with a list of arguments and returns the exit code and the +-- stdout and stderr output +readProgram :: Program -> [String] -> M (ExitCode, String, String) readProgram prog args = do + logExecute prog args + liftIO $ readProcessWithExitCode (prgPath prog) (prgFlags prog ++ args) "" + +-- | Runs a program with a list of arguments and returns the stdout output +readProgramStdout :: Program -> [String] -> M String +readProgramStdout prog args = do logExecute prog args liftIO $ readProcess (prgPath prog) (prgFlags prog ++ args) "" ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs ===================================== @@ -22,7 +22,7 @@ data Ar = Ar { arMkArchive :: Program findAr :: ProgOpt -> M Ar findAr progOpt = checking "for 'ar'" $ do bareAr <- findProgram "ar archiver" progOpt ["ar"] - arIsGnu <- ("GNU" `isInfixOf`) <$> readProgram bareAr ["--version"] + arIsGnu <- ("GNU" `isInfixOf`) <$> readProgramStdout bareAr ["--version"] -- Figure out how to invoke ar to create archives... mkArchive <- checking "for how to make archives" @@ -84,7 +84,7 @@ checkArSupportsDashL bareAr = checking "that ar supports -L" $ withTempDir $ \di callProgram bareAr ["qc", archive2, file "b0", file "b1"] oneOf "trying -L" [ do callProgram bareAr ["qcL", merged, archive1, archive2] - contents <- readProgram bareAr ["t", merged] + contents <- readProgramStdout bareAr ["t", merged] return $ not $ "conftest.a1" `isInfixOf` contents , return False ] @@ -98,7 +98,7 @@ checkArSupportsAtFile bareAr mkArchive = checking "that ar supports @-files" $ w createFile f writeFile atfile (unlines objs) callProgram mkArchive [archive, "@" ++ dir "conftest.atfile"] - contents <- readProgram bareAr ["t", archive] + contents <- readProgramStdout bareAr ["t", archive] if lines contents == objs then return True else logDebug "Contents didn't match" >> return False ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -77,8 +77,8 @@ checkSupportsNoPie ccLink = withTempDir $ \dir -> do let test = dir "test" -- Check output as some GCC versions only warn and don't respect -Werror -- when passed an unrecognized flag. - out <- readProgram ccLink ["-no-pie", "-Werror", "-x", "c", test_c, "-o", test] - if "unrecognized" `isInfixOf` out + (code, out, _err) <- readProgram ccLink ["-no-pie", "-Werror", "-x", "c", test_c, "-o", test] + if isSuccess code && "unrecognized" `isInfixOf` out then return False else return True @@ -119,7 +119,7 @@ checkBfdCopyBug archOs cc mb_readelf ccLink callProgram ccLink ["-o", exe, test_o, main_o, lib_so] - out <- readProgram (readelfProgram readelf) ["-r", exe] + out <- readProgramStdout (readelfProgram readelf) ["-r", exe] when ("R_ARM_COPY" `isInfixOf` out) $ throwE "Your linker is affected by binutils #16177. Please choose a different linker." ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs ===================================== @@ -36,14 +36,14 @@ checkMergingWorks cc nm mergeObjs = compileC cc (fo "a") "void funA(int x) { return x; }" compileC cc (fo "b") "void funB(int x) { return x; }" callProgram (mergeObjsProgram mergeObjs) [fo "a", fo "b", "-o", fo "out"] - out <- readProgram (nmProgram nm) [fo "out"] + out <- readProgramStdout (nmProgram nm) [fo "out"] let ok = all (`isInfixOf` out) ["funA", "funB"] unless ok $ throwE "merged objects is missing symbols" checkForGoldT22266 :: Cc -> CcLink -> MergeObjs -> M () checkForGoldT22266 cc ccLink mergeObjs = do version <- checking "for ld.gold object merging bug (binutils #22266)" $ - readProgram (mergeObjsProgram mergeObjs) ["--version"] + readProgramStdout (mergeObjsProgram mergeObjs) ["--version"] when ("gold" `isInfixOf` version) check_it where check_it = ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module GHC.Toolchain.Utils @@ -5,6 +6,7 @@ module GHC.Toolchain.Utils , expectFileExists , withTempDir , oneOf + , isSuccess ) where import Control.Monad @@ -13,6 +15,7 @@ import Control.Monad.IO.Class import System.Directory import System.FilePath import System.IO.Error +import System.Exit import GHC.Toolchain.Prelude @@ -52,3 +55,9 @@ expectFileExists path err = do oneOf :: String -> [M b] -> M b oneOf err = foldr (<|>) (throwE err) + +isSuccess :: ExitCode -> Bool +isSuccess = \case + ExitSuccess -> True + ExitFailure _ -> False + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/102ae4bc247076c8e70b57c5cec00c5dc82feaaf -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/102ae4bc247076c8e70b57c5cec00c5dc82feaaf You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 17:31:29 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 01 May 2023 13:31:29 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] 2 commits: ghc-toolchain: Rename readProcess to readProcessStdout Message-ID: <644ff7712eeff_178e74159a5e6502546611@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: 9651258b by Rodrigo Mesquita at 2023-05-01T17:37:40+01:00 ghc-toolchain: Rename readProcess to readProcessStdout Fixes bugs regarding a translation from the original autconf program that failed to account for the exit code. The longer name reenforces that we really only care about the stdout, and the exit code and stderr of the program are irrelevant for the case. - - - - - f0218199 by Rodrigo Mesquita at 2023-05-01T18:31:20+01:00 Re-introduce ld-override option - - - - - 8 changed files: - configure.ac - utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs - utils/ghc-toolchain/src/GHC/Toolchain/Program.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs - utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs - utils/ghc-toolchain/src/Main.hs Changes: ===================================== configure.ac ===================================== @@ -446,6 +446,11 @@ FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2]) dnl ** Which ld to use dnl -------------------------------------------------------------- AC_ARG_VAR(LD,[Use as the path to ld. See also --disable-ld-override.]) +AC_ARG_ENABLE(ld-override, + [AS_HELP_STRING([--disable-ld-override], + [Prevent GHC from overriding the default linker used by gcc. If ld-override is disabled GHC will try to tell gcc to use whichever linker is selected by the LD environment variable. [default=override enabled]])], + [], + [enable_ld_override=yes]) dnl ** Which objdump to use? dnl -------------------------------------------------------------- ===================================== utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs ===================================== @@ -96,7 +96,7 @@ checkLeadingUnderscore :: Cc -> Nm -> M Bool checkLeadingUnderscore cc nm = checking ctxt $ withTempDir $ \dir -> do let test_o = dir "test.o" compileC cc test_o prog - out <- readProgram (nmProgram nm) [test_o] + out <- readProgramStdout (nmProgram nm) [test_o] return $ "_func" `isInfixOf` out where prog = "int func(void) { return 0; }" ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Program.hs ===================================== @@ -6,6 +6,7 @@ module GHC.Toolchain.Program , runProgram , callProgram , readProgram + , readProgramStdout -- * Finding 'Program's , ProgOpt(..) , emptyProgOpt @@ -58,10 +59,20 @@ callProgram prog args = do , "Exited with code " ++ show n ] -readProgram :: Program -> [String] -> M String +-- | Runs a program with a list of arguments and returns the exit code and the +-- stdout and stderr output +readProgram :: Program -> [String] -> M (ExitCode, String, String) readProgram prog args = do logExecute prog args - liftIO $ readProcess (prgPath prog) (prgFlags prog ++ args) "" + liftIO $ readProcessWithExitCode (prgPath prog) (prgFlags prog ++ args) "" + +-- | Runs a program with a list of arguments and returns the stdout output +readProgramStdout :: Program -> [String] -> M String +readProgramStdout prog args = do + logExecute prog args + (_code, stdout, _stderr) <- liftIO $ readProcessWithExitCode (prgPath prog) (prgFlags prog ++ args) "" + -- Ignores the exit code! + return stdout logExecute :: Program -> [String] -> M () logExecute prog args = ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs ===================================== @@ -22,7 +22,7 @@ data Ar = Ar { arMkArchive :: Program findAr :: ProgOpt -> M Ar findAr progOpt = checking "for 'ar'" $ do bareAr <- findProgram "ar archiver" progOpt ["ar"] - arIsGnu <- ("GNU" `isInfixOf`) <$> readProgram bareAr ["--version"] + arIsGnu <- ("GNU" `isInfixOf`) <$> readProgramStdout bareAr ["--version"] -- Figure out how to invoke ar to create archives... mkArchive <- checking "for how to make archives" @@ -84,7 +84,7 @@ checkArSupportsDashL bareAr = checking "that ar supports -L" $ withTempDir $ \di callProgram bareAr ["qc", archive2, file "b0", file "b1"] oneOf "trying -L" [ do callProgram bareAr ["qcL", merged, archive1, archive2] - contents <- readProgram bareAr ["t", merged] + contents <- readProgramStdout bareAr ["t", merged] return $ not $ "conftest.a1" `isInfixOf` contents , return False ] @@ -98,7 +98,7 @@ checkArSupportsAtFile bareAr mkArchive = checking "that ar supports @-files" $ w createFile f writeFile atfile (unlines objs) callProgram mkArchive [archive, "@" ++ dir "conftest.atfile"] - contents <- readProgram bareAr ["t", archive] + contents <- readProgramStdout bareAr ["t", archive] if lines contents == objs then return True else logDebug "Contents didn't match" >> return False ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -22,8 +22,8 @@ data CcLink = CcLink { ccLinkProgram :: Program } deriving (Show, Read) -findCcLink :: ProgOpt -> ArchOS -> Cc -> Maybe Readelf -> M CcLink -findCcLink progOpt archOs cc readelf = checking "for C compiler for linking command" $ do +findCcLink :: ProgOpt -> Maybe Bool -> ArchOS -> Cc -> Maybe Readelf -> M CcLink +findCcLink progOpt ldOverride archOs cc readelf = checking "for C compiler for linking command" $ do ccLinkProgram <- case poPath progOpt of Just _ -> -- If the user specified a linker don't second-guess them @@ -31,16 +31,16 @@ findCcLink progOpt archOs cc readelf = checking "for C compiler for linking comm Nothing -> do -- If not then try to find a decent linker on our own rawCcLink <- findProgram "C compiler for linking" progOpt [prgPath $ ccProgram cc] - findLinkFlags cc rawCcLink <|> pure rawCcLink + findLinkFlags ldOverride cc rawCcLink <|> pure rawCcLink ccLinkSupportsNoPie <- checkSupportsNoPie ccLinkProgram checkBfdCopyBug archOs cc readelf ccLinkProgram ccLinkProgram <- addPlatformDepLinkFlags archOs cc ccLinkProgram return $ CcLink {ccLinkProgram, ccLinkSupportsNoPie} -- | Try to convince @cc@ to use a more efficient linker than @bfd.ld@ -findLinkFlags :: Cc -> Program -> M Program -findLinkFlags cc ccLink - | doLinkerSearch = +findLinkFlags :: Maybe Bool -> Cc -> Program -> M Program +findLinkFlags ldOverride cc ccLink + | enableOverride && doLinkerSearch = oneOf "this can't happen" [ -- Annoyingly, gcc silently falls back to vanilla ld (typically bfd -- ld) if @-fuse-ld@ is given with a non-existent linker. @@ -54,6 +54,13 @@ findLinkFlags cc ccLink <|> (ccLink <$ checkLinkWorks cc ccLink) | otherwise = return ccLink + where + enableOverride = case ldOverride of + -- ROMES: We're basically defining the default value here, + -- wouldn't it be better to define the default on construction? + Nothing -> True + Just True -> True + Just False -> False -- | Should we attempt to find a more efficient linker on this platform? -- @@ -77,8 +84,8 @@ checkSupportsNoPie ccLink = withTempDir $ \dir -> do let test = dir "test" -- Check output as some GCC versions only warn and don't respect -Werror -- when passed an unrecognized flag. - out <- readProgram ccLink ["-no-pie", "-Werror", "-x", "c", test_c, "-o", test] - if "unrecognized" `isInfixOf` out + (code, out, _err) <- readProgram ccLink ["-no-pie", "-Werror", "-x", "c", test_c, "-o", test] + if isSuccess code && "unrecognized" `isInfixOf` out then return False else return True @@ -119,7 +126,7 @@ checkBfdCopyBug archOs cc mb_readelf ccLink callProgram ccLink ["-o", exe, test_o, main_o, lib_so] - out <- readProgram (readelfProgram readelf) ["-r", exe] + out <- readProgramStdout (readelfProgram readelf) ["-r", exe] when ("R_ARM_COPY" `isInfixOf` out) $ throwE "Your linker is affected by binutils #16177. Please choose a different linker." ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs ===================================== @@ -36,14 +36,14 @@ checkMergingWorks cc nm mergeObjs = compileC cc (fo "a") "void funA(int x) { return x; }" compileC cc (fo "b") "void funB(int x) { return x; }" callProgram (mergeObjsProgram mergeObjs) [fo "a", fo "b", "-o", fo "out"] - out <- readProgram (nmProgram nm) [fo "out"] + out <- readProgramStdout (nmProgram nm) [fo "out"] let ok = all (`isInfixOf` out) ["funA", "funB"] unless ok $ throwE "merged objects is missing symbols" checkForGoldT22266 :: Cc -> CcLink -> MergeObjs -> M () checkForGoldT22266 cc ccLink mergeObjs = do version <- checking "for ld.gold object merging bug (binutils #22266)" $ - readProgram (mergeObjsProgram mergeObjs) ["--version"] + readProgramStdout (mergeObjsProgram mergeObjs) ["--version"] when ("gold" `isInfixOf` version) check_it where check_it = ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module GHC.Toolchain.Utils @@ -5,6 +6,7 @@ module GHC.Toolchain.Utils , expectFileExists , withTempDir , oneOf + , isSuccess ) where import Control.Monad @@ -13,6 +15,7 @@ import Control.Monad.IO.Class import System.Directory import System.FilePath import System.IO.Error +import System.Exit import GHC.Toolchain.Prelude @@ -52,3 +55,9 @@ expectFileExists path err = do oneOf :: String -> [M b] -> M b oneOf err = foldr (<|>) (throwE err) + +isSuccess :: ExitCode -> Bool +isSuccess = \case + ExitSuccess -> True + ExitFailure _ -> False + ===================================== utils/ghc-toolchain/src/Main.hs ===================================== @@ -44,6 +44,7 @@ data Opts = Opts , optDllwrap :: ProgOpt , optUnregisterised :: Maybe Bool , optTablesNextToCode :: Maybe Bool + , optLdOverride :: Maybe Bool , optVerbosity :: Int , optKeepTemp :: Bool } @@ -65,6 +66,7 @@ emptyOpts = Opts , optWindres = po0 , optUnregisterised = Nothing , optTablesNextToCode = Nothing + , optLdOverride = Nothing -- See comment in Link on 'enableOverride'. Shouldn't we set the default here? , optVerbosity = 0 , optKeepTemp = False } @@ -98,6 +100,9 @@ _optUnregisterised = Lens optUnregisterised (\x o -> o {optUnregisterised=x}) _optTablesNextToCode :: Lens Opts (Maybe Bool) _optTablesNextToCode = Lens optTablesNextToCode (\x o -> o {optTablesNextToCode=x}) +_optLdOvveride :: Lens Opts (Maybe Bool) +_optLdOvveride = Lens optLdOverride (\x o -> o {optLdOverride=x}) + _optVerbosity :: Lens Opts Int _optVerbosity = Lens optVerbosity (\x o -> o {optVerbosity=x}) @@ -114,6 +119,7 @@ options = concat [ enableDisable "unregisterised" "unregisterised backend" _optUnregisterised , enableDisable "tables-next-to-code" "Tables-next-to-code optimisation" _optTablesNextToCode + , enableDisable "ld-override" "override gcc's default linker" _optLdOvveride ] ++ concat [ progOpts "cc" "C compiler" _optCc @@ -235,13 +241,12 @@ determineTablesNextToCode determineTablesNextToCode archOs unreg userReq = case userReq of Just True + | not tntcSupported + -> throwE "Tables-next-to-code not supported by this platform" | unreg -> throwE "Tables-next-to-code cannot be used with unregisterised code generator" - | tntcSupported -> throwE "Tables-next-to-code not supported by this platform" | otherwise -> return True Just False -> return False - Nothing - | tntcSupported -> return True - | otherwise -> return False + Nothing -> pure tntcSupported where tntcSupported = tablesNextToCodeSupported archOs @@ -253,7 +258,7 @@ mkTarget opts = do archOs <- parseTriple cc0 (optTriple opts) cc <- addPlatformDepCcFlags archOs cc0 readelf <- optional $ findReadelf (optReadelf opts) - ccLink <- findCcLink (optCcLink opts) archOs cc readelf + ccLink <- findCcLink (optCcLink opts) (optLdOverride opts) archOs cc readelf ar <- findAr (optAr opts) ranlib <- if arNeedsRanlib ar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/102ae4bc247076c8e70b57c5cec00c5dc82feaaf...f02181995fcccea4e456431db8698dfd7a1309d6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/102ae4bc247076c8e70b57c5cec00c5dc82feaaf...f02181995fcccea4e456431db8698dfd7a1309d6 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 17:47:55 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Mon, 01 May 2023 13:47:55 -0400 Subject: [Git][ghc/ghc][wip/expand-do] a new check for irrefutable pattern Message-ID: <644ffb4bb68e8_178e74159eeb09c2547346@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 6b457021 by Apoorv Ingle at 2023-05-01T12:47:20-05:00 a new check for irrefutable pattern - - - - - 5 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -729,8 +729,8 @@ ppr_expr (XExpr x) = case ghcPass @p of ppr_expr (PopSrcSpan x) = case ghcPass @p of GhcPs -> panic "ppr_expr Ps HsPopSrcSpan" GhcRn -> ppr x - GhcTc -> panic "ppr_expr Tc HsPopSrcSpan" - + GhcTc -> panic "ppr_expr Tc HsPopSrcSpan" + instance Outputable XXExprGhcTc where ppr (WrapExpr (HsWrap co_fn e)) @@ -1114,9 +1114,9 @@ data HsExpansion orig expanded -- | Just print the original expression (the @a@) with the expanded version (the @b@) instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ppr (HsExpanded orig expanded) - = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - (ppr orig) - -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) + -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) + -- (ppr orig) + = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) {- ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -67,6 +67,7 @@ import GHC.Hs.Extension import GHC.Hs.Type import GHC.Tc.Types.Evidence import GHC.Types.Basic +import GHC.Types.TypeEnv import GHC.Types.SourceText -- others: import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) @@ -502,6 +503,7 @@ looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False looksLazyPat _ = True + isIrrefutableHsPat :: forall p. (OutputableBndrId p) => DynFlags -> LPat (GhcPass p) -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -858,14 +858,15 @@ warnDiscardedDoBindings rhs rhs_ty warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM () warnUnusedBindValue fun arg arg_ty - | Just (SrcSpanAnn _ l, f) <- fish_var fun + | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun , is_gen_then f -- , isNoSrcSpan l = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun , text "arg" <+> ppr arg , text "arg_ty" <+> ppr arg_ty , text "f" <+> ppr f <+> ppr (is_gen_then f) - , text "l" <+> ppr (isNoSrcSpan l)]) + , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc) + ]) warnDiscardedDoBindings arg arg_ty where -- retrieve the location info and the head of the application @@ -879,8 +880,8 @@ warnUnusedBindValue fun arg arg_ty fish_var _ = Nothing -- is this id a compiler generated (>>) with expanded do - is_gen_then :: LIdP GhcTc -> Bool - is_gen_then (L _ f) = f `hasKey` thenMClassOpKey + is_gen_then :: Id -> Bool + is_gen_then f = f `hasKey` thenMClassOpKey warnUnusedBindValue _ _ _ = return () ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -59,7 +59,6 @@ import GHC.Tc.Types.Evidence import GHC.Core.Multiplicity import GHC.Core.UsageEnv -import GHC.Core.ConLike import GHC.Core.TyCon -- Create chunkified tuple types for monad comprehensions import GHC.Core.Make @@ -81,6 +80,7 @@ import GHC.Types.Name import GHC.Types.Id import GHC.Types.SrcLoc import GHC.Types.Basic (Origin (..)) +import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Control.Arrow ( second ) @@ -1381,19 +1381,19 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc -- generate a fail block even if it is not really needed. This would fail typechecking as -- a monad fail instance for such datatypes maynot be defined. cf. GHC.Hs.isIrrefutableHsPat mk_failable_lexpr_tcm pat lexpr fail_op = - do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation) - PatBindRhs pat $ return id -- whatever - ; dflags <- getDynFlags - ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr tc_pat - , ppr $ isIrrefutableHsPat dflags tc_pat - , ppr $ isPatSynCon (unLoc tc_pat)]) - ; if isIrrefutableHsPat dflags tc_pat -- don't decorate with fail statement if the pattern is irrefutable - || (isPatSynCon (unLoc tc_pat)) -- pattern syns always get a fail block while desugaring so skip + do { tc_env <- getGblEnv + ; is_strict <- xoptM LangExt.Strict + ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat + , ppr $ isIrrefutableHsPatRn tc_env is_strict pat + ]) + + ; if isIrrefutableHsPatRn tc_env is_strict pat + -- don't decorate with fail statement if the pattern is irrefutable + -- pattern syns always get a fail block while desugaring so skip then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } - where isPatSynCon (ConPat {pat_con = L _ (PatSynCon _)}) = True - isPatSynCon _ = False + where -- makes the fail block -- TODO: check the discussion around MonadFail.fail type signature. @@ -1401,9 +1401,9 @@ mk_failable_lexpr_tcm pat lexpr fail_op = mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn) mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) = do dflags <- getDynFlags - return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \ + return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \ (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) -- pat -> expr - , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern" + , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern" (noLocA $ genHsApp fail_op (mk_fail_msg_expr dflags (DoExpr Nothing) pat)) ])) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -20,6 +20,7 @@ module GHC.Tc.Gen.Pat , tcCheckPat, tcCheckPat_O, tcInferPat , tcPats , addDataConStupidTheta + , isIrrefutableHsPatRn ) where @@ -40,6 +41,7 @@ import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader +import GHC.Types.TypeEnv (lookupTypeEnv) import GHC.Core.Multiplicity import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env @@ -77,6 +79,7 @@ import GHC.Data.List.SetOps ( getNth ) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Data.List( partition ) +import Data.Maybe (isJust) {- ************************************************************************ @@ -1619,3 +1622,45 @@ checkGADT conlike ex_tvs arg_tys = \case where has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs + + +isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat + where + goL :: LPat GhcRn -> Bool + goL = go . unLoc + + go :: Pat GhcRn -> Bool + go (WildPat {}) = True + go (VarPat {}) = True + go (LazyPat _ p') + | is_strict + = isIrrefutableHsPatRn tc_env False p' + | otherwise = True + go (BangPat _ pat) = goL pat + go (ParPat _ _ pat _) = goL pat + go (AsPat _ _ _ pat) = goL pat + go (ViewPat _ _ pat) = goL pat + go (SigPat _ pat _) = goL pat + go (TuplePat _ pats _) = all goL pats + go (SumPat {}) = False + -- See Note [Unboxed sum patterns aren't irrefutable] + go (ListPat {}) = False + + go (ConPat + { pat_con = L _ dcName + , pat_args = details }) = case lookupTypeEnv type_env dcName of + Just (ATyCon con) -> + isJust (tyConSingleDataCon_maybe con) + && all goL (hsConPatArgs details) + _ -> False -- conservative. + go (LitPat {}) = False + go (NPat {}) = False + go (NPlusKPat {}) = False + + -- We conservatively assume that no TH splices are irrefutable + -- since we cannot know until the splice is evaluated. + go (SplicePat {}) = False + + go (XPat ext) = case ext of + HsPatExpanded _ pat -> go pat View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6b4570211c23fd8ab3b03843886782003203948b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6b4570211c23fd8ab3b03843886782003203948b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 19:41:32 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Mon, 01 May 2023 15:41:32 -0400 Subject: [Git][ghc/ghc][wip/expand-do] a new check for irrefutable pattern Message-ID: <645015ec66f32_178e7415bee54ec2559185@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: f477fa38 by Apoorv Ingle at 2023-05-01T14:41:20-05:00 a new check for irrefutable pattern - - - - - 7 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/Language/Haskell/Syntax/Expr.hs - testsuite/tests/rebindable/T18324b.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -729,8 +729,8 @@ ppr_expr (XExpr x) = case ghcPass @p of ppr_expr (PopSrcSpan x) = case ghcPass @p of GhcPs -> panic "ppr_expr Ps HsPopSrcSpan" GhcRn -> ppr x - GhcTc -> panic "ppr_expr Tc HsPopSrcSpan" - + GhcTc -> panic "ppr_expr Tc HsPopSrcSpan" + instance Outputable XXExprGhcTc where ppr (WrapExpr (HsWrap co_fn e)) @@ -1114,9 +1114,9 @@ data HsExpansion orig expanded -- | Just print the original expression (the @a@) with the expanded version (the @b@) instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ppr (HsExpanded orig expanded) - = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - (ppr orig) - -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) + -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) + -- (ppr orig) + = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) {- ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -502,6 +502,7 @@ looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False looksLazyPat _ = True + isIrrefutableHsPat :: forall p. (OutputableBndrId p) => DynFlags -> LPat (GhcPass p) -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -858,14 +858,15 @@ warnDiscardedDoBindings rhs rhs_ty warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM () warnUnusedBindValue fun arg arg_ty - | Just (SrcSpanAnn _ l, f) <- fish_var fun + | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun , is_gen_then f -- , isNoSrcSpan l = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun , text "arg" <+> ppr arg , text "arg_ty" <+> ppr arg_ty , text "f" <+> ppr f <+> ppr (is_gen_then f) - , text "l" <+> ppr (isNoSrcSpan l)]) + , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc) + ]) warnDiscardedDoBindings arg arg_ty where -- retrieve the location info and the head of the application @@ -879,8 +880,8 @@ warnUnusedBindValue fun arg arg_ty fish_var _ = Nothing -- is this id a compiler generated (>>) with expanded do - is_gen_then :: LIdP GhcTc -> Bool - is_gen_then (L _ f) = f `hasKey` thenMClassOpKey + is_gen_then :: Id -> Bool + is_gen_then f = f `hasKey` thenMClassOpKey warnUnusedBindValue _ _ _ = return () ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -59,7 +59,6 @@ import GHC.Tc.Types.Evidence import GHC.Core.Multiplicity import GHC.Core.UsageEnv -import GHC.Core.ConLike import GHC.Core.TyCon -- Create chunkified tuple types for monad comprehensions import GHC.Core.Make @@ -81,6 +80,7 @@ import GHC.Types.Name import GHC.Types.Id import GHC.Types.SrcLoc import GHC.Types.Basic (Origin (..)) +import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Control.Arrow ( second ) @@ -1237,8 +1237,8 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts) , fail_op <- xbsrn_failOp xbsrn = -- the pattern binding x can fail -- instead of making an internal name, the fail block is just an anonymous match block --- stmts ~~> stmt' let / = stmts'; --- _ = fail ".."; +-- stmts ~~> stmt' let / pat = stmts'; +-- _ = fail "Pattern match failure .." -- ------------------------------------------------------- -- pat <- e ; stmts ~~> (>>=) e f do expand_stmts <- expand_do_stmts do_or_lc lstmts @@ -1381,19 +1381,19 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc -- generate a fail block even if it is not really needed. This would fail typechecking as -- a monad fail instance for such datatypes maynot be defined. cf. GHC.Hs.isIrrefutableHsPat mk_failable_lexpr_tcm pat lexpr fail_op = - do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation) - PatBindRhs pat $ return id -- whatever - ; dflags <- getDynFlags - ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr tc_pat - , ppr $ isIrrefutableHsPat dflags tc_pat - , ppr $ isPatSynCon (unLoc tc_pat)]) - ; if isIrrefutableHsPat dflags tc_pat -- don't decorate with fail statement if the pattern is irrefutable - || (isPatSynCon (unLoc tc_pat)) -- pattern syns always get a fail block while desugaring so skip + do { tc_env <- getGblEnv + ; is_strict <- xoptM LangExt.Strict + ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat + , ppr $ isIrrefutableHsPatRn tc_env is_strict pat + ]) + + ; if isIrrefutableHsPatRn tc_env is_strict pat + -- don't decorate with fail statement if the pattern is irrefutable + -- pattern syns always get a fail block while desugaring so skip then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } - where isPatSynCon (ConPat {pat_con = L _ (PatSynCon _)}) = True - isPatSynCon _ = False + where -- makes the fail block -- TODO: check the discussion around MonadFail.fail type signature. @@ -1401,9 +1401,9 @@ mk_failable_lexpr_tcm pat lexpr fail_op = mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn) mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) = do dflags <- getDynFlags - return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \ + return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \ (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) -- pat -> expr - , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern" + , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern" (noLocA $ genHsApp fail_op (mk_fail_msg_expr dflags (DoExpr Nothing) pat)) ])) @@ -1415,3 +1415,10 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) = <+> text "at" <+> ppr (getLocA pat) mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty + +{- Note [Desugaring Do with HsExpansion] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand do blocks before typeching it rather than after type checking it +TODO expand using examples + +-} ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -20,6 +20,7 @@ module GHC.Tc.Gen.Pat , tcCheckPat, tcCheckPat_O, tcInferPat , tcPats , addDataConStupidTheta + , isIrrefutableHsPatRn ) where @@ -40,6 +41,7 @@ import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader +import GHC.Types.TypeEnv (lookupTypeEnv) import GHC.Core.Multiplicity import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env @@ -77,6 +79,7 @@ import GHC.Data.List.SetOps ( getNth ) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Data.List( partition ) +import Data.Maybe (isJust) {- ************************************************************************ @@ -1619,3 +1622,45 @@ checkGADT conlike ex_tvs arg_tys = \case where has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs + + +isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat + where + goL :: LPat GhcRn -> Bool + goL = go . unLoc + + go :: Pat GhcRn -> Bool + go (WildPat {}) = True + go (VarPat {}) = True + go (LazyPat _ p') + | is_strict + = isIrrefutableHsPatRn tc_env False p' + | otherwise = True + go (BangPat _ pat) = goL pat + go (ParPat _ _ pat _) = goL pat + go (AsPat _ _ _ pat) = goL pat + go (ViewPat _ _ pat) = goL pat + go (SigPat _ pat _) = goL pat + go (TuplePat _ pats _) = all goL pats + go (SumPat {}) = False + -- See Note [Unboxed sum patterns aren't irrefutable] + go (ListPat {}) = False + + go (ConPat + { pat_con = L _ dcName + , pat_args = details }) = case lookupTypeEnv type_env dcName of + Just (ATyCon con) -> + isJust (tyConSingleDataCon_maybe con) + && all goL (hsConPatArgs details) + _ -> False -- conservative. + go (LitPat {}) = False + go (NPat {}) = False + go (NPlusKPat {}) = False + + -- We conservatively assume that no TH splices are irrefutable + -- since we cannot know until the splice is evaluated. + go (SplicePat {}) = False + + go (XPat ext) = case ext of + HsPatExpanded _ pat -> go pat ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -587,7 +587,7 @@ data HsExpr p | PopSrcSpan (LHsExpr p) -- Placeholder for identifying generated source locations in GhcRn phase -- Should not presist post typechecking - -- Note [Desugaring Do with HsExpansion] TODO + -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match -- --------------------------------------------------------------------- ===================================== testsuite/tests/rebindable/T18324b.hs ===================================== @@ -14,7 +14,7 @@ unLoc (L _ e) = e data B = B -type family Anno a = b +type family Anno a = b type family XRec p a = r | r -> a type instance XRec (GhcPass p) a = L (Anno a) a @@ -33,17 +33,14 @@ type GhcRn = GhcPass 'Rn data ClsInstDecl pass = ClsInstDecl { cid_datafam_insts :: LDataFamInstDecl pass } - --- type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass) type LDataFamInstDecl pass = XRec pass ([FamEqn pass (HsDataDefn pass)]) --- type TyFamDefltDecl = TyFamInstDecl type family IdP p type instance IdP (GhcPass p) = IdGhcP p type LIdP p = XRec p (IdP p) -data HsDataDefn pass +data HsDataDefn pass data FamEqn pass rhs = FamEqn @@ -54,7 +51,9 @@ fffggg :: ClsInstDecl GhcRn -> [Int] fffggg ddd = -- let do FamEqn { feqn_tycon = L _ _ - , feqn_rhs = _ } {-:: FamEqn GhcRn (HsDataDefn GhcRn)-} <- unLoc $ cid_datafam_insts ddd - [ 0 ] - - + , feqn_rhs = defns } :: FamEqn GhcRn (HsDataDefn GhcRn) <- unLoc $ cid_datafam_insts ddd + [ 0 ] ++ dataSubs defns + where + dataSubs :: HsDataDefn GhcRn + -> [Int] + dataSubs = undefined View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f477fa38f40b35768110a7005578773ac8db7c17 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f477fa38f40b35768110a7005578773ac8db7c17 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 20:11:47 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Mon, 01 May 2023 16:11:47 -0400 Subject: [Git][ghc/ghc][wip/expand-do] a new check for irrefutable pattern Message-ID: <64501d03882d_178e7415c4c1e88256018a@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 9201e4ce by Apoorv Ingle at 2023-05-01T15:11:25-05:00 a new check for irrefutable pattern - - - - - 9 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/Language/Haskell/Syntax/Expr.hs - testsuite/tests/rebindable/T18324b.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -729,8 +729,8 @@ ppr_expr (XExpr x) = case ghcPass @p of ppr_expr (PopSrcSpan x) = case ghcPass @p of GhcPs -> panic "ppr_expr Ps HsPopSrcSpan" GhcRn -> ppr x - GhcTc -> panic "ppr_expr Tc HsPopSrcSpan" - + GhcTc -> panic "ppr_expr Tc HsPopSrcSpan" + instance Outputable XXExprGhcTc where ppr (WrapExpr (HsWrap co_fn e)) @@ -1114,9 +1114,9 @@ data HsExpansion orig expanded -- | Just print the original expression (the @a@) with the expanded version (the @b@) instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ppr (HsExpanded orig expanded) - = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - (ppr orig) - -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) + -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) + -- (ppr orig) + = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) {- ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -502,6 +502,7 @@ looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False looksLazyPat _ = True + isIrrefutableHsPat :: forall p. (OutputableBndrId p) => DynFlags -> LPat (GhcPass p) -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -858,14 +858,15 @@ warnDiscardedDoBindings rhs rhs_ty warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM () warnUnusedBindValue fun arg arg_ty - | Just (SrcSpanAnn _ l, f) <- fish_var fun + | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun , is_gen_then f -- , isNoSrcSpan l = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun , text "arg" <+> ppr arg , text "arg_ty" <+> ppr arg_ty , text "f" <+> ppr f <+> ppr (is_gen_then f) - , text "l" <+> ppr (isNoSrcSpan l)]) + , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc) + ]) warnDiscardedDoBindings arg arg_ty where -- retrieve the location info and the head of the application @@ -879,8 +880,8 @@ warnUnusedBindValue fun arg arg_ty fish_var _ = Nothing -- is this id a compiler generated (>>) with expanded do - is_gen_then :: LIdP GhcTc -> Bool - is_gen_then (L _ f) = f `hasKey` thenMClassOpKey + is_gen_then :: Id -> Bool + is_gen_then f = f `hasKey` thenMClassOpKey warnUnusedBindValue _ _ _ = return () ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -605,6 +605,7 @@ addTickHsExpr (XExpr (HsTick t e)) = liftM (XExpr . HsTick t) (addTickLHsExprNever e) addTickHsExpr (XExpr (HsBinTick t0 t1 e)) = liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e) +addTickHsExpr e@(PopSrcSpan _) = pprPanic "addTickHsExpr: impossible happen PopSrcSpan" (ppr e) addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -59,7 +59,6 @@ import GHC.Tc.Types.Evidence import GHC.Core.Multiplicity import GHC.Core.UsageEnv -import GHC.Core.ConLike import GHC.Core.TyCon -- Create chunkified tuple types for monad comprehensions import GHC.Core.Make @@ -81,6 +80,7 @@ import GHC.Types.Name import GHC.Types.Id import GHC.Types.SrcLoc import GHC.Types.Basic (Origin (..)) +import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Control.Arrow ( second ) @@ -1237,8 +1237,8 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts) , fail_op <- xbsrn_failOp xbsrn = -- the pattern binding x can fail -- instead of making an internal name, the fail block is just an anonymous match block --- stmts ~~> stmt' let / = stmts'; --- _ = fail ".."; +-- stmts ~~> stmt' let / pat = stmts'; +-- _ = fail "Pattern match failure .." -- ------------------------------------------------------- -- pat <- e ; stmts ~~> (>>=) e f do expand_stmts <- expand_do_stmts do_or_lc lstmts @@ -1381,19 +1381,19 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc -- generate a fail block even if it is not really needed. This would fail typechecking as -- a monad fail instance for such datatypes maynot be defined. cf. GHC.Hs.isIrrefutableHsPat mk_failable_lexpr_tcm pat lexpr fail_op = - do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation) - PatBindRhs pat $ return id -- whatever - ; dflags <- getDynFlags - ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr tc_pat - , ppr $ isIrrefutableHsPat dflags tc_pat - , ppr $ isPatSynCon (unLoc tc_pat)]) - ; if isIrrefutableHsPat dflags tc_pat -- don't decorate with fail statement if the pattern is irrefutable - || (isPatSynCon (unLoc tc_pat)) -- pattern syns always get a fail block while desugaring so skip + do { tc_env <- getGblEnv + ; is_strict <- xoptM LangExt.Strict + ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat + , ppr $ isIrrefutableHsPatRn tc_env is_strict pat + ]) + + ; if isIrrefutableHsPatRn tc_env is_strict pat + -- don't decorate with fail statement if the pattern is irrefutable + -- pattern syns always get a fail block while desugaring so skip then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } - where isPatSynCon (ConPat {pat_con = L _ (PatSynCon _)}) = True - isPatSynCon _ = False + where -- makes the fail block -- TODO: check the discussion around MonadFail.fail type signature. @@ -1401,9 +1401,9 @@ mk_failable_lexpr_tcm pat lexpr fail_op = mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn) mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) = do dflags <- getDynFlags - return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \ + return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \ (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) -- pat -> expr - , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern" + , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern" (noLocA $ genHsApp fail_op (mk_fail_msg_expr dflags (DoExpr Nothing) pat)) ])) @@ -1415,3 +1415,10 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) = <+> text "at" <+> ppr (getLocA pat) mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty + +{- Note [Desugaring Do with HsExpansion] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand do blocks before typeching it rather than after type checking it +TODO expand using examples + +-} ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -20,6 +20,7 @@ module GHC.Tc.Gen.Pat , tcCheckPat, tcCheckPat_O, tcInferPat , tcPats , addDataConStupidTheta + , isIrrefutableHsPatRn ) where @@ -40,6 +41,7 @@ import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader +import GHC.Types.TypeEnv (lookupTypeEnv) import GHC.Core.Multiplicity import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env @@ -77,6 +79,7 @@ import GHC.Data.List.SetOps ( getNth ) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Data.List( partition ) +import Data.Maybe (isJust) {- ************************************************************************ @@ -1619,3 +1622,45 @@ checkGADT conlike ex_tvs arg_tys = \case where has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs + + +isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat + where + goL :: LPat GhcRn -> Bool + goL = go . unLoc + + go :: Pat GhcRn -> Bool + go (WildPat {}) = True + go (VarPat {}) = True + go (LazyPat _ p') + | is_strict + = isIrrefutableHsPatRn tc_env False p' + | otherwise = True + go (BangPat _ pat) = goL pat + go (ParPat _ _ pat _) = goL pat + go (AsPat _ _ _ pat) = goL pat + go (ViewPat _ _ pat) = goL pat + go (SigPat _ pat _) = goL pat + go (TuplePat _ pats _) = all goL pats + go (SumPat {}) = False + -- See Note [Unboxed sum patterns aren't irrefutable] + go (ListPat {}) = False + + go (ConPat + { pat_con = L _ dcName + , pat_args = details }) = case lookupTypeEnv type_env dcName of + Just (ATyCon con) -> + isJust (tyConSingleDataCon_maybe con) + && all goL (hsConPatArgs details) + _ -> False -- conservative. + go (LitPat {}) = False + go (NPat {}) = False + go (NPlusKPat {}) = False + + -- We conservatively assume that no TH splices are irrefutable + -- since we cannot know until the splice is evaluated. + go (SplicePat {}) = False + + go (XPat ext) = case ext of + HsPatExpanded _ pat -> go pat ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -725,6 +725,7 @@ exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice" exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a +exprCtOrigin (PopSrcSpan (L _ e)) = exprCtOrigin e -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -587,7 +587,7 @@ data HsExpr p | PopSrcSpan (LHsExpr p) -- Placeholder for identifying generated source locations in GhcRn phase -- Should not presist post typechecking - -- Note [Desugaring Do with HsExpansion] TODO + -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match -- --------------------------------------------------------------------- ===================================== testsuite/tests/rebindable/T18324b.hs ===================================== @@ -14,7 +14,7 @@ unLoc (L _ e) = e data B = B -type family Anno a = b +type family Anno a = b type family XRec p a = r | r -> a type instance XRec (GhcPass p) a = L (Anno a) a @@ -33,17 +33,14 @@ type GhcRn = GhcPass 'Rn data ClsInstDecl pass = ClsInstDecl { cid_datafam_insts :: LDataFamInstDecl pass } - --- type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass) type LDataFamInstDecl pass = XRec pass ([FamEqn pass (HsDataDefn pass)]) --- type TyFamDefltDecl = TyFamInstDecl type family IdP p type instance IdP (GhcPass p) = IdGhcP p type LIdP p = XRec p (IdP p) -data HsDataDefn pass +data HsDataDefn pass data FamEqn pass rhs = FamEqn @@ -54,7 +51,9 @@ fffggg :: ClsInstDecl GhcRn -> [Int] fffggg ddd = -- let do FamEqn { feqn_tycon = L _ _ - , feqn_rhs = _ } {-:: FamEqn GhcRn (HsDataDefn GhcRn)-} <- unLoc $ cid_datafam_insts ddd - [ 0 ] - - + , feqn_rhs = defns } :: FamEqn GhcRn (HsDataDefn GhcRn) <- unLoc $ cid_datafam_insts ddd + [ 0 ] ++ dataSubs defns + where + dataSubs :: HsDataDefn GhcRn + -> [Int] + dataSubs = undefined View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9201e4ce457cfc82d5c574b81833066b2b7325d5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9201e4ce457cfc82d5c574b81833066b2b7325d5 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 20:54:32 2023 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Mon, 01 May 2023 16:54:32 -0400 Subject: [Git][ghc/ghc][wip/t23315] Insert documentation into parsed signature modules Message-ID: <64502708d3272_178e7415d27011025628c7@gitlab.mail> Finley McIlwaine pushed to branch wip/t23315 at Glasgow Haskell Compiler / GHC Commits: 37f93685 by Finley McIlwaine at 2023-05-01T14:53:55-06:00 Insert documentation into parsed signature modules Causes haddock comments in signature modules to be properly inserted into the AST (just as they are for regular modules) if the `-haddock` flag is given. Also adds a test that compares `-ddump-parsed-ast` output for a signature module to prevent further regressions. Fixes #23315 - - - - - 7 changed files: - compiler/GHC/Parser.y - + testsuite/tests/parser/should_compile/T23315/Makefile - + testsuite/tests/parser/should_compile/T23315/Setup.hs - + testsuite/tests/parser/should_compile/T23315/T23315.cabal - + testsuite/tests/parser/should_compile/T23315/T23315.hsig - + testsuite/tests/parser/should_compile/T23315/T23315.stderr - + testsuite/tests/parser/should_compile/T23315/all.T Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -743,7 +743,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } -- Exported parsers %name parseModuleNoHaddock module -%name parseSignature signature +%name parseSignatureNoHaddock signature %name parseImport importdecl %name parseStatement e_stmt %name parseDeclaration topdecl @@ -4376,18 +4376,29 @@ pvL :: MonadP m => m (LocatedAn t a) -> m (Located a) pvL a = do { av <- a ; return (reLoc av) } --- | Parse a Haskell module with Haddock comments. --- This is done in two steps: +-- | Parse a Haskell module with Haddock comments. This is done in two steps: -- -- * 'parseModuleNoHaddock' to build the AST -- * 'addHaddockToModule' to insert Haddock comments into it -- --- This is the only parser entry point that deals with Haddock comments. --- The other entry points ('parseDeclaration', 'parseExpression', etc) do --- not insert them into the AST. +-- This and the signature module parser are the only parser entry points that +-- deal with Haddock comments. The other entry points ('parseDeclaration', +-- 'parseExpression', etc) do not insert them into the AST. parseModule :: P (Located (HsModule GhcPs)) parseModule = parseModuleNoHaddock >>= addHaddockToModule +-- | Parse a Haskell signature module with Haddock comments. This is done in two +-- steps: +-- +-- * 'parseSignatureNoHaddock' to build the AST +-- * 'addHaddockToModule' to insert Haddock comments into it +-- +-- This and the module parser are the only parser entry points that deal with +-- Haddock comments. The other entry points ('parseDeclaration', +-- 'parseExpression', etc) do not insert them into the AST. +parseSignature :: P (Located (HsModule GhcPs)) +parseSignature = parseSignatureNoHaddock >>= addHaddockToModule + commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann) commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc ===================================== testsuite/tests/parser/should_compile/T23315/Makefile ===================================== @@ -0,0 +1,18 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP = ./Setup -v0 + +T23315: clean + $(MAKE) clean + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup + $(SETUP) clean + $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' + $(SETUP) build 1>&2 +ifneq "$(CLEANUP)" "" + $(MAKE) clean +endif + +clean : + $(RM) -r */dist Setup$(exeext) *.o *.hi ===================================== testsuite/tests/parser/should_compile/T23315/Setup.hs ===================================== @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain \ No newline at end of file ===================================== testsuite/tests/parser/should_compile/T23315/T23315.cabal ===================================== @@ -0,0 +1,10 @@ +name: T23315 +version: 0.1.0.0 +build-type: Simple +cabal-version: 2.0 + +library + signatures: T23315 + build-depends: base >= 4.3 && < 5 + default-language: Haskell2010 + ghc-options: -Wall -haddock -ddump-parsed-ast ===================================== testsuite/tests/parser/should_compile/T23315/T23315.hsig ===================================== @@ -0,0 +1,4 @@ +signature T23315 where +-- | My unit +a :: () +-- ^ More docs ===================================== testsuite/tests/parser/should_compile/T23315/T23315.stderr ===================================== @@ -0,0 +1,112 @@ + +==================== Parser AST ==================== + +(L + { T23315.hsig:1:1 } + (HsModule + (XModulePs + (EpAnn + (Anchor + { T23315.hsig:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddEpAnn AnnSignature (EpaSpan { T23315.hsig:1:1-9 })) + ,(AddEpAnn AnnWhere (EpaSpan { T23315.hsig:1:18-22 }))] + [] + (Nothing)) + (EpaComments + [])) + (VirtualBraces + (1)) + (Nothing) + (Nothing)) + (Just + (L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:1:11-16 }) + {ModuleName: T23315})) + (Nothing) + [] + [(L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:2:1-12 }) + (DocD + (NoExtField) + (DocCommentNext + (L + { T23315.hsig:2:1-12 } + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringNext) + (:| + (L + { T23315.hsig:2:5-12 } + (HsDocStringChunk + " My unit")) + [])) + []))))) + ,(L + (SrcSpanAnn (EpAnn + (Anchor + { T23315.hsig:3:1-7 } + (UnchangedAnchor)) + (AnnListItem + []) + (EpaComments + [])) { T23315.hsig:3:1-7 }) + (SigD + (NoExtField) + (TypeSig + (EpAnn + (Anchor + { T23315.hsig:3:1 } + (UnchangedAnchor)) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T23315.hsig:3:3-4 })) + []) + (EpaComments + [])) + [(L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:1 }) + (Unqual + {OccName: a}))] + (HsWC + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:6-7 }) + (HsSig + (NoExtField) + (HsOuterImplicit + (NoExtField)) + (L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:6-7 }) + (HsTupleTy + (EpAnn + (Anchor + { T23315.hsig:3:6 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (EpaSpan { T23315.hsig:3:6 }) + (EpaSpan { T23315.hsig:3:7 })) + (EpaComments + [])) + (HsBoxedOrConstraintTuple) + [])))))))) + ,(L + (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:4:1-14 }) + (DocD + (NoExtField) + (DocCommentPrev + (L + { T23315.hsig:4:1-14 } + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringPrevious) + (:| + (L + { T23315.hsig:4:5-14 } + (HsDocStringChunk + " More docs")) + [])) + [])))))])) + + ===================================== testsuite/tests/parser/should_compile/T23315/all.T ===================================== @@ -0,0 +1,3 @@ +test('T23315', + [extra_files(['Setup.hs']), js_broken(22352)], + makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37f936856fcccb61cf52e57a08cbfa54a86e3c78 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37f936856fcccb61cf52e57a08cbfa54a86e3c78 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 21:41:49 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Mon, 01 May 2023 17:41:49 -0400 Subject: [Git][ghc/ghc][wip/T23070-unify] Use the eager unifier in the constraint solver Message-ID: <6450321d5f058_178e7415dd721f8256837f@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23070-unify at Glasgow Haskell Compiler / GHC Commits: 06072d2f by Simon Peyton Jones at 2023-05-01T22:43:20+01:00 Use the eager unifier in the constraint solver This patch continues the refactoring of the constraint solver described in #23070. The Big Deal in this patch is to call the regular, eager unifier from the constraint solver, when we want to create new equalities. This replaces the existing, unifyWanted which amounted to yet-another-unifier, so it reduces duplication of a rather subtle piece of technology. See * Note [The eager unifier] in GHC.Tc.Utils.Unify * GHC.Tc.Solver.Monad.wrapUnifierTcS I did lots of other refactoring along the way * I simplified the treatment of right hand sides that contain CoercionHoles. Now, a constraint that contains a hetero-kind CoercionHole is non-canonical, and cannot be used for rewriting or unification alike. This required me to add the ch_hertero_kind flag to CoercionHole, with consequent knock-on effects. See wrinkle (2) of `Note [Equalities with incompatible kinds]` in GHC.Tc.Solver.Equality. * I refactored the StopOrContinue type to add StartAgain, so that after a fundep improvement (for example) we can simply start the pipeline again. * I got rid of the unpleasant (and inefficient) rewriterSetFromType/Co functions. With Richard I concluded that they are never needed. * I discovered Wrinkle (W1) in Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint, and therefore now prioritise non-rewritten equalities. Quite a few error messages change, I think always for the better. Compiler runtime stays about the same, with one outlier: a 17% improvement in T17836 Metric Decrease: T17836 T18223 - - - - - 28 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion.hs-boot - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Reduction.hs - compiler/GHC/Core/TyCo/Compare.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/HsToCore.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Rule.hs - compiler/GHC/Tc/Plugin.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Canonical.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Interact.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/06072d2f547e84af96c07bd21091773135ffc6c9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/06072d2f547e84af96c07bd21091773135ffc6c9 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 1 21:51:21 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Mon, 01 May 2023 17:51:21 -0400 Subject: [Git][ghc/ghc][wip/T23307] 5 commits: Add the Unsatisfiable class Message-ID: <64503459e98_178e7415e21f4bc25704a@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23307 at Glasgow Haskell Compiler / GHC Commits: 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - fbdea779 by Simon Peyton Jones at 2023-05-01T19:55:08+01:00 Make GHC.Types.Id.Make.shouldUnpackTy a bit more clever As #23307, GHC.Types.Id.Make.shouldUnpackTy was leaving money on the table, failing to unpack arguments that are perfectly unpackable. The fix is pretty easy; see Note [Recursive unboxing] - - - - - b4cf71f8 by Simon Peyton Jones at 2023-05-01T19:55:08+01:00 Wibbles - - - - - 79aa2318 by Simon Peyton Jones at 2023-05-01T22:52:47+01:00 Make it even more clever adding T23307a - - - - - 30 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Types.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Make.hs - docs/users_guide/9.8.1-notes.rst - libraries/base/GHC/TypeError.hs - libraries/base/changelog.md - testsuite/tests/deriving/should_compile/T17324.stderr - testsuite/tests/driver/t22391/t22391.stderr - testsuite/tests/driver/t22391/t22391j.stderr - testsuite/tests/ghci/prog018/prog018.stdout The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/30365bebdd0eeae3ccf7386a2b08ac2bfafd07cf...79aa2318ed1909f25e04b849896bf74e5f66d4f2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/30365bebdd0eeae3ccf7386a2b08ac2bfafd07cf...79aa2318ed1909f25e04b849896bf74e5f66d4f2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 00:06:48 2023 From: gitlab at gitlab.haskell.org (Ryan Scott (@RyanGlScott)) Date: Mon, 01 May 2023 20:06:48 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/T23329 Message-ID: <645054186efe4_178e7416056e5942578892@gitlab.mail> Ryan Scott pushed new branch wip/T23329 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T23329 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 00:11:26 2023 From: gitlab at gitlab.haskell.org (Ryan Scott (@RyanGlScott)) Date: Mon, 01 May 2023 20:11:26 -0400 Subject: [Git][ghc/ghc][wip/T23329] Fix type variable substitution in gen_Newtype_fam_insts Message-ID: <6450552e8061e_178e741607247d02582350@gitlab.mail> Ryan Scott pushed to branch wip/T23329 at Glasgow Haskell Compiler / GHC Commits: c3e83ddb by Ryan Scott at 2023-05-01T20:11:17-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch copies the same code over to `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 5 changed files: - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/TyCl/Class.hs - + testsuite/tests/deriving/should_compile/T23329.hs - + testsuite/tests/deriving/should_compile/T23329_M.hs - testsuite/tests/deriving/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -92,7 +92,7 @@ import GHC.Unit.Module import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Data.List ( find, partition, intersperse ) +import Data.List ( find, mapAccumL, partition, intersperse ) -- | A declarative description of an auxiliary binding that should be -- generated. See @Note [Auxiliary binders]@ for a more detailed description @@ -2089,6 +2089,18 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty rhs_env = zipTyEnv cls_tvs underlying_inst_tys rhs_subst = mkTvSubst in_scope rhs_env + subst_tvs :: Subst -> [TyVar] -> (Subst, [Type]) + subst_tvs = mapAccumL subst_tv + + subst_tv :: Subst -> TyVar -> (Subst, Type) + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) + mk_atf_inst :: TyCon -> TcM FamInst mk_atf_inst fam_tc = do rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc)) @@ -2100,8 +2112,8 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty newFamInst SynFamilyInst axiom where fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs + (_, rep_lhs_tys) = subst_tvs lhs_subst fam_tvs + (_, rep_rhs_tys) = subst_tvs rhs_subst fam_tvs rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -526,6 +526,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) = do { warnMissingAT (tyConName fam_tc) ; return [] } where + subst_tv :: Subst -> TyVar -> (Subst, Type) subst_tv subst tc_tv | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty) ===================================== testsuite/tests/deriving/should_compile/T23329.hs ===================================== @@ -0,0 +1,9 @@ +module T23329 where + +import Data.Kind (Type) +import Data.Proxy (Proxy(Proxy)) + +import T23329_M + +foo :: () +foo = myMethod @Type @MyMaybe @() () Proxy Proxy ===================================== testsuite/tests/deriving/should_compile/T23329_M.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module T23329_M where + +import Data.Kind (Type) +import Data.Proxy (Proxy) + +class MyClass (f :: k -> Type) where + type MyTypeFamily f (i :: k) :: Type + myMethod :: MyTypeFamily f i -> Proxy f -> Proxy i -> () + +instance MyClass Maybe where + type MyTypeFamily Maybe i = () + myMethod = undefined + +newtype MyMaybe a = MyMaybe (Maybe a) + deriving MyClass ===================================== testsuite/tests/deriving/should_compile/all.T ===================================== @@ -141,3 +141,4 @@ test('T20994', normal, compile, ['']) test('T22167', normal, compile, ['']) test('T22696a', normal, compile, ['']) test('T22696c', normal, compile, ['']) +test('T23329', normal, multimod_compile, ['T23329', '-v0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c3e83ddb4c4cb2ef4c263bc350ee452ba8c4a30d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c3e83ddb4c4cb2ef4c263bc350ee452ba8c4a30d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 07:44:57 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Tue, 02 May 2023 03:44:57 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/riscv-moritz-rebase Message-ID: <6450bf79ddeb5_178e74167abb57c260784f@gitlab.mail> Sven Tennie pushed new branch wip/riscv-moritz-rebase at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/riscv-moritz-rebase You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 08:55:51 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Tue, 02 May 2023 04:55:51 -0400 Subject: [Git][ghc/ghc][wip/ghcup-metadata-nightly] Testing Message-ID: <6450d01742068_178e74168df9ef426269b7@gitlab.mail> Matthew Pickering pushed to branch wip/ghcup-metadata-nightly at Glasgow Haskell Compiler / GHC Commits: f2af4694 by GHC GitLab CI at 2023-05-02T09:43:55+01:00 Testing - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -999,7 +999,7 @@ project-version: - . ./version.sh # Download existing ghcup metadata - - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://gitlab.haskell.org/ghc/ghcup-metadata/-/raw/main/ghcup-0.0.7.yaml" + - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://gitlab.haskell.org/ghc/ghcup-metadata/-/raw/updates/ghcup-0.0.7.yaml" - .gitlab/generate_job_metadata @@ -1072,7 +1072,7 @@ ghcup-metadata-nightly-push: - git remote add gitlab_origin https://oauth2:$PROJECT_PUSH_TOKEN at gitlab.haskell.org/ghc/ghcup-metadata.git - git add . - git commit -m "Update metadata" - - git push gitlab_origin HEAD:main -o ci.skip + - git push gitlab_origin HEAD:updates -o ci.skip rules: - if: $NIGHTLY # - if: $CI_PIPELINE_SOURCE == "schedule" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2af46940ac4d2a40d71af67e3d419b307485157 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2af46940ac4d2a40d71af67e3d419b307485157 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 09:24:50 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Tue, 02 May 2023 05:24:50 -0400 Subject: [Git][ghc/ghc][wip/ghcup-metadata-nightly] 38 commits: hadrian: Pass haddock file arguments in a response file Message-ID: <6450d6e295d65_178e74169717cfc26391a3@gitlab.mail> Matthew Pickering pushed to branch wip/ghcup-metadata-nightly at Glasgow Haskell Compiler / GHC Commits: f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - a864418d by GHC GitLab CI at 2023-05-02T10:02:05+01:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - + compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/Stg/Debug.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f2af46940ac4d2a40d71af67e3d419b307485157...a864418d1422da2fe185a51fc7a24c51de7b92ff -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f2af46940ac4d2a40d71af67e3d419b307485157...a864418d1422da2fe185a51fc7a24c51de7b92ff You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 09:25:30 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Tue, 02 May 2023 05:25:30 -0400 Subject: [Git][ghc/ghc][wip/ghcup-metadata-nightly] Incrementally update ghcup metadata in ghc/ghcup-metadata Message-ID: <6450d70a5125c_178e741697657f4263937c@gitlab.mail> Matthew Pickering pushed to branch wip/ghcup-metadata-nightly at Glasgow Haskell Compiler / GHC Commits: 7f382a00 by Matthew Pickering at 2023-05-02T10:25:23+01:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -999,7 +999,7 @@ project-version: - . ./version.sh # Download existing ghcup metadata - - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://raw.githubusercontent.com/haskell/ghcup-metadata/develop/ghcup-0.0.7.yaml" + - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://gitlab.haskell.org/ghc/ghcup-metadata/-/raw/updates/ghcup-0.0.7.yaml" - .gitlab/generate_job_metadata @@ -1048,6 +1048,37 @@ ghcup-metadata-nightly: rules: - if: $NIGHTLY +# Update the +ghcup-metadata-nightly-push: + stage: deploy + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + dependencies: null + tags: + - x86_64-linux + variables: + BUILD_FLAVOUR: default + GIT_SUBMODULE_STRATEGY: "none" + needs: + - job: ghcup-metadata-nightly + artifacts: true + script: + - git clone https://gitlab.haskell.org/ghc/ghcup-metadata.git + - cp metadata_test.yaml ghcup-metadata/ghcup-0.0.7.yaml + - cd ghcup-metadata + - git config user.email "ghc-ci at gitlab-haskell.org" + - git config user.name "GHC GitLab CI" + - git remote add gitlab_origin https://oauth2:$PROJECT_PUSH_TOKEN at gitlab.haskell.org/ghc/ghcup-metadata.git + - git add . + - git commit -m "Update metadata" + - git push gitlab_origin HEAD:updates -o ci.skip + rules: + - if: $NIGHTLY + # Only run the update on scheduled nightly pipelines, ie once a day + - if: $CI_PIPELINE_SOURCE == "schedule" + # And only update the metadata for master branch + - if: '$CI_COMMIT_BRANCH == "master"' + + ghcup-metadata-release: # No explicit needs for release pipeline as we assume we need everything and everything will pass. extends: .ghcup-metadata View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f382a007930c03662573f2ce33cd3a93477d554 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f382a007930c03662573f2ce33cd3a93477d554 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 09:26:10 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Tue, 02 May 2023 05:26:10 -0400 Subject: [Git][ghc/ghc][wip/ghcup-metadata-nightly] Incrementally update ghcup metadata in ghc/ghcup-metadata Message-ID: <6450d732becbf_178e7416989069c26395dc@gitlab.mail> Matthew Pickering pushed to branch wip/ghcup-metadata-nightly at Glasgow Haskell Compiler / GHC Commits: b5de89fe by Matthew Pickering at 2023-05-02T10:25:47+01:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -999,7 +999,7 @@ project-version: - . ./version.sh # Download existing ghcup metadata - - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://raw.githubusercontent.com/haskell/ghcup-metadata/develop/ghcup-0.0.7.yaml" + - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://gitlab.haskell.org/ghc/ghcup-metadata/-/raw/updates/ghcup-0.0.7.yaml" - .gitlab/generate_job_metadata @@ -1048,6 +1048,37 @@ ghcup-metadata-nightly: rules: - if: $NIGHTLY +# Update the +ghcup-metadata-nightly-push: + stage: deploy + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + dependencies: null + tags: + - x86_64-linux + variables: + BUILD_FLAVOUR: default + GIT_SUBMODULE_STRATEGY: "none" + needs: + - job: ghcup-metadata-nightly + artifacts: true + script: + - git clone https://gitlab.haskell.org/ghc/ghcup-metadata.git + - cp metadata_test.yaml ghcup-metadata/ghcup-0.0.7.yaml + - cd ghcup-metadata + - git config user.email "ghc-ci at gitlab-haskell.org" + - git config user.name "GHC GitLab CI" + - git remote add gitlab_origin https://oauth2:$PROJECT_PUSH_TOKEN at gitlab.haskell.org/ghc/ghcup-metadata.git + - git add . + - git commit -m "Update metadata" + - git push gitlab_origin HEAD:updates -o ci.skip + rules: + - if: $NIGHTLY + # Only run the update on scheduled nightly pipelines, ie once a day + - if: $CI_PIPELINE_SOURCE == "schedule" + # And only update the metadata for master branch + - if: '$CI_COMMIT_BRANCH == "master"' + + ghcup-metadata-release: # No explicit needs for release pipeline as we assume we need everything and everything will pass. extends: .ghcup-metadata View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b5de89fec18270c18fb60369931131bfd41d780b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b5de89fec18270c18fb60369931131bfd41d780b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 11:54:54 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Tue, 02 May 2023 07:54:54 -0400 Subject: [Git][ghc/ghc][wip/codebuffer-perftest] base/encoding: add an allocations performance test (#22946) Message-ID: <6450fa0e9a228_178e7416be82c24269462c@gitlab.mail> Josh Meredith pushed to branch wip/codebuffer-perftest at Glasgow Haskell Compiler / GHC Commits: 5b8f25c4 by Josh Meredith at 2023-05-02T11:54:40+00:00 base/encoding: add an allocations performance test (#22946) - - - - - 2 changed files: - libraries/base/tests/perf/all.T - + libraries/base/tests/perf/encodingAllocations.hs Changes: ===================================== libraries/base/tests/perf/all.T ===================================== @@ -1,5 +1,14 @@ +# .stats files aren't yet supported in the JS backend +setTestOpts(js_skip) + #-------------------------------------- # Check specialization of elem via rules #-------------------------------------- test('T17752', [only_ways(['normal'])] , makefile_test, ['T17752']) + +#-------------------------------------- + +# We don't expect the code in test to vary at all, but the variance is set to +# 1% in case the constant allocations increase by other means. +test('encodingAllocations', [only_ways(['normal']), collect_stats('bytes allocated', 1)], compile_and_run, ['-O2']) ===================================== libraries/base/tests/perf/encodingAllocations.hs ===================================== @@ -0,0 +1,30 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -dno-typeable-binds -O2 #-} + +module Main (main) where + +import System.IO +import Data.Bits +import GHC.Int +import GHC.Exts +import System.Environment +import Distribution.Simple.Utils + + +main :: IO () +main = withTempFile "." "encodingAllocations.tmp" (const $ loop 1000000) + +loop :: Int -> Handle -> IO () +loop 0 !_ = pure () +loop !n !h = do + hPutChar h $! dummy_char n + loop (n-1) h + +-- unsafe efficient version of `chr` +my_chr :: Int -> Char +my_chr (I# i) = C# (chr# i) + +-- return either a or b +dummy_char :: Int -> Char +dummy_char !i = my_chr ((i .&. 1) + 97) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b8f25c466bdc0f5345cbc020c207d94540d84f8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b8f25c466bdc0f5345cbc020c207d94540d84f8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 12:04:47 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Tue, 02 May 2023 08:04:47 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <6450fc5f9b69a_178e7416c3678342699560@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: f9fd8f57 by Josh Meredith at 2023-05-02T12:04:22+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 6 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform ( identsS @@ -22,7 +23,6 @@ module GHC.JS.Transform , composOpM_ , composOpFold , satJExpr - , satJStat ) where @@ -200,54 +200,34 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v - +jsSaturate :: Maybe FastString -> JStat -> Sat.JStat +jsSaturate str x = evalState (go x) (newIdentSupply str) + where + go :: JStat -> State [Ident] Sat.JStat + go = \case + DeclStat i rhs -> return $ Sat.DeclStat i (fmap satJExpr rhs) + ReturnStat e -> return $ Sat.ReturnStat (satJExpr e) + IfStat c t e -> Sat.IfStat (satJExpr c) <$> go t <*> go e + WhileStat is_do c e -> Sat.WhileStat is_do (satJExpr c) <$> go e + ForInStat is_each i iter body -> Sat.ForInStat is_each i (satJExpr iter) <$> go body + SwitchStat struct ps def -> Sat.SwitchStat (satJExpr struct) + <$> mapM (\(p1, p2) -> (satJExpr p1,) <$> go p2) ps + <*> go def + TryStat t i c f -> Sat.TryStat <$> go t <*> pure i <*> go c <*> go f + BlockStat bs -> fmap Sat.BlockStat $! mapM go bs + ApplStat rator rand -> return $ Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) + UOpStat rator rand -> return $ Sat.UOpStat (satJUOp rator) (satJExpr rand) + AssignStat lhs rhs -> return $ Sat.AssignStat (satJExpr lhs) (satJExpr rhs) + LabelStat lbl stmt -> Sat.LabelStat lbl <$> go stmt + BreakStat m_l -> return $ Sat.BreakStat $! m_l + ContinueStat m_l -> return $ Sat.ContinueStat $! m_l + UnsatBlock us -> go =<< runIdentSupply us -------------------------------------------------------------------------------- -- Translation -- -- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing - - -- This is an Applicative but we can't use it because no type variables :( - witness :: JStat -> Sat.JStat - witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) - witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) - witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) - witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) - witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i - (satJExpr iter) - (witness body) - witness (SwitchStat struct ps def) = Sat.SwitchStat - (satJExpr struct) - (map (satJExpr *** witness) ps) - (witness def) - witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) - witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs - witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) - witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) - witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) - witness (BreakStat Nothing) = Sat.BreakStat Nothing - witness (BreakStat (Just l)) = Sat.BreakStat $! Just l - witness (ContinueStat Nothing) = Sat.ContinueStat Nothing - witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l - witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" - satJExpr :: JExpr -> Sat.JExpr satJExpr = go @@ -315,5 +295,5 @@ satJVal = go go (JStr f) = Sat.JStr f go (JRegEx f) = Sat.JRegEx f go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) + go (JFunc args body) = Sat.JFunc args (jsSaturate Nothing body) go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a +saturateFFI :: Int -> JStat -> Sat.JStat saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) @@ -180,4 +181,4 @@ globalOccs jst = do let g = GlobalOcc i gid 1 in go (addToUFM_C inc gids i g) is - pure $ go emptyUFM (identsS $ satJStat jst) + pure $ go emptyUFM (identsS jst) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat +rtsDecls :: Sat.JStat rtsDecls = jsSaturate (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread @@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat +rts :: StgToJSConfig -> Sat.JStat rts = jsSaturate (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9fd8f57c4dd5a871770df7165dbd1647064ddf7 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9fd8f57c4dd5a871770df7165dbd1647064ddf7 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 12:19:49 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Tue, 02 May 2023 08:19:49 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <6450ffe5d908f_178e7416c81f9d0270495b@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 379bdcf8 by Josh Meredith at 2023-05-02T12:19:36+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 6 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform ( identsS @@ -22,7 +23,6 @@ module GHC.JS.Transform , composOpM_ , composOpFold , satJExpr - , satJStat ) where @@ -33,7 +33,6 @@ import GHC.JS.Unsat.Syntax import Data.Functor.Identity import Control.Monad -import Control.Arrow ((***)) import GHC.Data.FastString import GHC.Utils.Monad.State.Strict @@ -200,54 +199,34 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v - +jsSaturate :: Maybe FastString -> JStat -> Sat.JStat +jsSaturate str x = evalState (go x) (newIdentSupply str) + where + go :: JStat -> State [Ident] Sat.JStat + go = \case + DeclStat i rhs -> return $ Sat.DeclStat i (fmap satJExpr rhs) + ReturnStat e -> return $ Sat.ReturnStat (satJExpr e) + IfStat c t e -> Sat.IfStat (satJExpr c) <$> go t <*> go e + WhileStat is_do c e -> Sat.WhileStat is_do (satJExpr c) <$> go e + ForInStat is_each i iter body -> Sat.ForInStat is_each i (satJExpr iter) <$> go body + SwitchStat struct ps def -> Sat.SwitchStat (satJExpr struct) + <$> mapM (\(p1, p2) -> (satJExpr p1,) <$> go p2) ps + <*> go def + TryStat t i c f -> Sat.TryStat <$> go t <*> pure i <*> go c <*> go f + BlockStat bs -> fmap Sat.BlockStat $! mapM go bs + ApplStat rator rand -> return $ Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) + UOpStat rator rand -> return $ Sat.UOpStat (satJUOp rator) (satJExpr rand) + AssignStat lhs rhs -> return $ Sat.AssignStat (satJExpr lhs) (satJExpr rhs) + LabelStat lbl stmt -> Sat.LabelStat lbl <$> go stmt + BreakStat m_l -> return $ Sat.BreakStat $! m_l + ContinueStat m_l -> return $ Sat.ContinueStat $! m_l + UnsatBlock us -> go =<< runIdentSupply us -------------------------------------------------------------------------------- -- Translation -- -- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing - - -- This is an Applicative but we can't use it because no type variables :( - witness :: JStat -> Sat.JStat - witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) - witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) - witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) - witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) - witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i - (satJExpr iter) - (witness body) - witness (SwitchStat struct ps def) = Sat.SwitchStat - (satJExpr struct) - (map (satJExpr *** witness) ps) - (witness def) - witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) - witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs - witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) - witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) - witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) - witness (BreakStat Nothing) = Sat.BreakStat Nothing - witness (BreakStat (Just l)) = Sat.BreakStat $! Just l - witness (ContinueStat Nothing) = Sat.ContinueStat Nothing - witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l - witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" - satJExpr :: JExpr -> Sat.JExpr satJExpr = go @@ -315,5 +294,5 @@ satJVal = go go (JStr f) = Sat.JStr f go (JRegEx f) = Sat.JRegEx f go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) + go (JFunc args body) = Sat.JFunc args (jsSaturate Nothing body) go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a +saturateFFI :: Int -> JStat -> Sat.JStat saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) @@ -180,4 +181,4 @@ globalOccs jst = do let g = GlobalOcc i gid 1 in go (addToUFM_C inc gids i g) is - pure $ go emptyUFM (identsS $ satJStat jst) + pure $ go emptyUFM (identsS jst) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat +rtsDecls :: Sat.JStat rtsDecls = jsSaturate (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread @@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat +rts :: StgToJSConfig -> Sat.JStat rts = jsSaturate (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/379bdcf8c0c1bb3c4ff5170ccc4e69d2c17b55f6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/379bdcf8c0c1bb3c4ff5170ccc4e69d2c17b55f6 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 12:48:05 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Tue, 02 May 2023 08:48:05 -0400 Subject: [Git][ghc/ghc][wip/unitidset] WIP refactor `Set UnitId` to `UniqDSet UnitId` Message-ID: <64510685f05c3_178e7416d0fb5a4270936e@gitlab.mail> Josh Meredith pushed to branch wip/unitidset at Glasgow Haskell Compiler / GHC Commits: a2aaf8ea by Josh Meredith at 2023-05-02T12:47:37+00:00 WIP refactor `Set UnitId` to `UniqDSet UnitId` - - - - - 21 changed files: - compiler/GHC.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Types/Unique/DSet.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -395,6 +395,7 @@ import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -418,8 +419,6 @@ import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as S import qualified Data.Sequence as Seq import System.Directory @@ -604,7 +603,7 @@ setSessionDynFlags dflags0 = do logger <- getLogger dflags <- checkNewDynFlags logger dflags0 let all_uids = hsc_all_home_unit_ids hsc_env - case S.toList all_uids of + case uniqDSetToList all_uids of [uid] -> do setUnitDynFlagsNoCheck uid dflags modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags)) @@ -1379,7 +1378,7 @@ data ModuleInfo = ModuleInfo { -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do - if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env + if moduleUnitId mdl `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env then liftIO $ getHomeModuleInfo hsc_env mdl else liftIO $ getPackageModuleInfo hsc_env mdl @@ -1756,7 +1755,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, UnitIdSet) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -56,12 +56,11 @@ import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) +import GHC.Types.Unique.DSet import System.Directory import System.FilePath import System.IO -import Data.Set (Set) -import qualified Data.Set as Set {- ************************************************************************ @@ -84,7 +83,7 @@ codeOutput -> (a -> ForeignStubs) -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with the C compiler - -> Set UnitId -- ^ Dependencies + -> UnitIdSet -- ^ Dependencies -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), @@ -161,11 +160,11 @@ outputC :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a - -> Set UnitId + -> UnitIdSet -> IO a outputC logger dflags filenm cmm_stream unit_deps = withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do - let pkg_names = map unitIdString (Set.toAscList unit_deps) + let pkg_names = map unitIdString (uniqDSetToAscList unit_deps) doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h "#include \"Stg.h\"\n" ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -127,7 +127,7 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env -hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId +hsc_all_home_unit_ids :: HscEnv -> UnitIdSet hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -245,6 +245,7 @@ import GHC.Types.Name.Ppr import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic @@ -274,7 +275,6 @@ import Data.IORef import System.FilePath as FilePath import System.Directory import qualified Data.Set as S -import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) @@ -1457,15 +1457,15 @@ checkSafeImports tcg_env clearDiagnostics -- Check safe imports are correct - safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safePkgs <- mkUniqDSet <$> mapMaybeM checkSafe safeImps safeErrs <- getDiagnostics clearDiagnostics -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyMessages, S.empty) - True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + False -> return (emptyMessages, emptyUniqDSet) + True -> do infPkgs <- mkUniqDSet <$> mapMaybeM checkSafe regImps infErrs <- getDiagnostics clearDiagnostics return (infErrs, infPkgs) @@ -1516,12 +1516,12 @@ checkSafeImports tcg_env checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> + pkgTrustReqs :: DynFlags -> UnitIdSet -> UnitIdSet -> Bool -> ImportAvails pkgTrustReqs dflags req inf infPassed | safeInferOn dflags && not (safeHaskellModeEnabled dflags) && infPassed = emptyImportAvails { - imp_trust_pkgs = req `S.union` inf + imp_trust_pkgs = req `unionUniqDSets` inf } pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe = emptyImportAvails @@ -1540,12 +1540,12 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyMessages errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, UnitIdSet) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l good <- isEmptyMessages `fmap` getDiagnostics clearDiagnostics -- don't want them printed... - let pkgs' | Just p <- self = S.insert p pkgs + let pkgs' | Just p <- self = addOneToUniqDSet pkgs p | otherwise = pkgs return (good, pkgs') @@ -1554,7 +1554,7 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe UnitId, Set UnitId) + -> Hsc (Maybe UnitId, UnitIdSet) hscCheckSafe' m l = do hsc_env <- getHscEnv let home_unit = hsc_home_unit hsc_env @@ -1566,7 +1566,7 @@ hscCheckSafe' m l = do -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) where - isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) + isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, UnitIdSet) isModSafe home_unit m l = do hsc_env <- getHscEnv dflags <- getDynFlags @@ -1648,10 +1648,10 @@ hscCheckSafe' m l = do -- | Check the list of packages are trusted. -checkPkgTrust :: Set UnitId -> Hsc () +checkPkgTrust :: UnitIdSet -> Hsc () checkPkgTrust pkgs = do hsc_env <- getHscEnv - let errors = S.foldr go emptyBag pkgs + let errors = foldr go emptyBag $ uniqDSetToAscList pkgs state = hsc_units hsc_env go pkg acc | unitIsTrusted $ unsafeLookupUnitId state pkg @@ -1699,7 +1699,7 @@ markUnsafeInfer tcg_env whyUnsafe = do False -> return tcg_env where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = emptyUniqDSet } pprMod = ppr $ moduleName $ tcg_mod tcg_env whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" @@ -2060,7 +2060,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs in NoStubs `appendStubC` ip_init | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] emptyUniqDSet rawCmms return stub_c_exists where ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -107,6 +107,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Types.PkgQual import GHC.Unit @@ -490,7 +491,7 @@ load how_much = loadWithCache noIfaceCache how_much mkBatchMsg :: HscEnv -> Messager mkBatchMsg hsc_env = - if length (hsc_all_home_unit_ids hsc_env) > 1 + if sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 -- This also displays what unit each module is from. then batchMultiMsg else batchMsg @@ -1735,25 +1736,25 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages] +checkHomeUnitsClosed :: UnitEnv -> UnitIdSet -> [(UnitId, UnitId)] -> [DriverMessages] -- Fast path, trivially closed. checkHomeUnitsClosed ue home_id_set home_imp_ids - | Set.size home_id_set == 1 = [] + | sizeUniqDSet home_id_set == 1 = [] | otherwise = - let res = foldMap loop home_imp_ids + let res = foldr (\ids acc -> unionUniqDSets acc $ loop ids) emptyUniqDSet home_imp_ids -- Now check whether everything which transitively depends on a home_unit is actually a home_unit -- These units are the ones which we need to load as home packages but failed to do for some reason, -- it's a bug in the tool invoking GHC. - bad_unit_ids = Set.difference res home_id_set - in if Set.null bad_unit_ids + bad_unit_ids = res `minusUniqDSet` home_id_set + in if isEmptyUniqDSet bad_unit_ids then [] - else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (uniqDSetToAscList bad_unit_ids)] where rootLoc = mkGeneralSrcSpan (fsLit "") -- TODO: This could repeat quite a bit of work but I struggled to write this function. -- Which units transitively depend on a home unit - loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit + loop :: (UnitId, UnitId) -> UnitIdSet -- The units which transitively depend on a home unit loop (from_uid, uid) = let us = ue_findHomeUnitEnv from_uid ue in let um = unitInfoMap (homeUnitEnv_units us) in @@ -1761,20 +1762,21 @@ checkHomeUnitsClosed ue home_id_set home_imp_ids Nothing -> pprPanic "uid not found" (ppr uid) Just ui -> let depends = unitDepends ui - home_depends = Set.fromList depends `Set.intersection` home_id_set - other_depends = Set.fromList depends `Set.difference` home_id_set + home_depends = mkUniqDSet depends `intersectUniqDSets` home_id_set + other_depends = mkUniqDSet depends `minusUniqDSet` home_id_set in -- Case 1: The unit directly depends on a home_id - if not (null home_depends) + if not (isEmptyUniqDSet home_depends) then - let res = foldMap (loop . (from_uid,)) other_depends - in Set.insert uid res + let res :: UnitIdSet + res = foldl' (\acc ide -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends + in addOneToUniqDSet res uid -- Case 2: Check the rest of the dependencies, and then see if any of them depended on else - let res = foldMap (loop . (from_uid,)) other_depends + let res = foldl' (\acc ide -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends in - if not (Set.null res) - then Set.insert uid res + if not (isEmptyUniqDSet res) + then addOneToUniqDSet res uid else res -- | Update the every ModSummary that is depended on ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -108,6 +108,7 @@ import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.SourceError +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -125,7 +126,6 @@ import Control.Monad import qualified Control.Monad.Catch as MC (handle) import Data.Maybe import Data.Either ( partitionEithers ) -import qualified Data.Set as Set import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp @@ -408,8 +408,8 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt home_mod_infos = eltsHpt hpt -- the packages we depend on - pkg_deps = Set.toList - $ Set.unions + pkg_deps = uniqDSetToAscList + $ unionManyUniqDSets $ fmap (dep_direct_pkgs . mi_deps . hm_iface) $ home_mod_infos ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -40,7 +41,6 @@ import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.Set as Set import GHC.Linker.Types import GHC.Unit.Finder @@ -196,7 +196,7 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do mk_mod_usage_info :: UsageConfig -> HomeUnit - -> Set.Set UnitId + -> UnitIdSet -> Module -> ImportedMods -> NameSet @@ -255,7 +255,7 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names -- (need to recompile if its export list changes: export_fprint) mkUsage :: Module -> ModIface -> Maybe Usage mkUsage mod iface - | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids + | not $ toUnitId (moduleUnit mod) `elementOfUniqDSet` home_unit_ids = Just $ UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -504,7 +504,7 @@ loadInterface doc_str mod from -- overlapping instances. ; massertPpr ((isOneShot (ghcMode (hsc_dflags hsc_env))) - || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env + || not (moduleUnitId mod `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env) || mod == gHC_PRIM) (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique.Set import GHC.Types.Fixity.Env import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State @@ -617,8 +618,8 @@ checkDependencies hsc_env summary iface all_home_units = hsc_all_home_unit_ids hsc_env units = hsc_units hsc_env prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) - prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) - (dep_plugin_pkgs (mi_deps iface))) + prev_dep_pkgs = uniqDSetToAscList (unionUniqDSets (dep_direct_pkgs (mi_deps iface)) + (dep_plugin_pkgs (mi_deps iface))) implicit_deps = map (fsLit "Implicit",) (implicitPackageDeps dflags) @@ -633,7 +634,7 @@ checkDependencies hsc_env summary iface classify _ (Found _ mod) - | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) + | (toUnitId $ moduleUnit mod) `elementOfUniqDSet` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -324,20 +324,20 @@ loadCmdLineLibs interp hsc_env = do loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState loadCmdLineLibs' interp hsc_env pls = snd <$> foldM - (\(done', pls') cur_uid -> load done' cur_uid pls') - (Set.empty, pls) - (hsc_all_home_unit_ids hsc_env) + (\(done', pls') cur_uid -> load done' cur_uid pls') + (emptyUniqDSet, pls) + (uniqDSetToList $ hsc_all_home_unit_ids hsc_env) where - load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState) - load done uid pls | uid `Set.member` done = return (done, pls) + load :: UnitIdSet -> UnitId -> LoaderState -> IO (UnitIdSet, LoaderState) + load done uid pls | uid `elementOfUniqDSet` done = return (done, pls) load done uid pls = do let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (homeUnitDepends (hsc_units hsc')) pls'' <- loadCmdLineLibs'' interp hsc' pls' - return $ (Set.insert uid done', pls'') + return $ (addOneToUniqDSet done' uid, pls'') loadCmdLineLibs'' :: Interp @@ -685,7 +685,7 @@ getLinkDeps :: HscEnv -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first + -> IO ([Linkable], [Linkable], [UnitId], UnitIdSet) -- ... then link these first -- The module and package dependencies for the needed modules are returned. -- See Note [Object File Dependencies] -- Fails with an IO exception if it can't find enough files @@ -737,7 +737,7 @@ getLinkDeps hsc_env pls replace_osuf span mods -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop :: (UnitIdSet, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UnitIdSet, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts @@ -766,7 +766,7 @@ getLinkDeps hsc_env pls replace_osuf span mods HsBootFile -> link_boot_mod_error (mi_module iface) _ -> return $ Just (mi_module iface) - in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod + in (dep_direct_pkgs (mi_deps iface),) <$> mmod Nothing -> let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid in throwGhcExceptionIO (ProgramError (showSDoc dflags err)) @@ -780,9 +780,9 @@ getLinkDeps hsc_env pls replace_osuf span mods -- dependencies of that. Hence we need to traverse the dependency -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow - -> UniqDSet Module -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([Module], UniqDSet UnitId) -- result + -> UniqDSet Module -- accum. module dependencies + -> UnitIdSet -- accum. package dependencies + -> IO ([Module], UnitIdSet) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -814,7 +814,7 @@ getLinkDeps hsc_env pls replace_osuf span mods acc_mods' = case hsc_home_unit_maybe hsc_env of Nothing -> acc_mods Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs (uniqDSetToList pkg_deps) case hsc_home_unit_maybe hsc_env of Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -37,7 +37,7 @@ module GHC.Linker.Types where import GHC.Prelude -import GHC.Unit ( UnitId, Module ) +import GHC.Unit ( UnitId, Module, UnitIdSet ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) import GHCi.RemoteTypes ( ForeignHValue ) @@ -53,7 +53,6 @@ import Control.Concurrent.MVar import Data.Time ( UTCTime ) import Data.Maybe import GHC.Unit.Module.Env -import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM import GHC.Unit.Module.WholeCoreBindings @@ -146,7 +145,7 @@ data LoadedPkgInfo { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] - , loaded_pkg_trans_deps :: UniqDSet UnitId + , loaded_pkg_trans_deps :: UnitIdSet } instance Outputable LoadedPkgInfo where ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -75,6 +75,7 @@ import GHC.Types.HpcInfo import GHC.Types.Error import GHC.Types.PkgQual import GHC.Types.GREInfo (ConInfo(..)) +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Module.Warnings @@ -213,8 +214,8 @@ rnImports imports = do let merged_import_avail = clobberSourceImports imp_avails dflags <- getDynFlags let final_import_avail = - merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags) - `S.union` imp_dep_direct_pkgs merged_import_avail} + merged_import_avail { imp_dep_direct_pkgs = mkUniqDSet (implicitPackageDeps dflags) + `unionUniqDSets` imp_dep_direct_pkgs merged_import_avail} return (decls, rdr_env, final_import_avail, hpc_usage) where @@ -494,7 +495,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit - -> S.Set UnitId + -> UnitIdSet -> ModIface -> IsSafeImport -> IsBootInterface @@ -549,7 +550,7 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by -- Trusted packages are a lot like orphans. trusted_pkgs | mod_safe' = dep_trusted_pkgs deps - | otherwise = S.empty + | otherwise = emptyUniqDSet pkg = moduleUnit (mi_module iface) @@ -562,11 +563,11 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by | isHomeUnit home_unit pkg = ptrust | otherwise = False - dependent_pkgs = if toUnitId pkg `S.member` other_home_units - then S.empty - else S.singleton ipkg + dependent_pkgs = if toUnitId pkg `elementOfUniqDSet` other_home_units + then emptyUniqDSet + else unitUniqDSet ipkg - direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units + direct_mods = mkModDeps $ if toUnitId pkg `elementOfUniqDSet` other_home_units then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) else S.empty ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -148,6 +148,7 @@ import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -185,7 +186,6 @@ import Data.List ( sortBy, sort ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.Ord -import qualified Data.Set as S import Data.Traversable ( for ) @@ -3134,7 +3134,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , text "Dependent modules:" <+> (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_direct_pkgs imports)] + ppr (uniqDSetToAscList $ imp_dep_direct_pkgs imports)] -- The use of sort is just to reduce unnecessary -- wobbling in testsuite output ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -142,6 +142,7 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo @@ -1367,9 +1368,9 @@ plusModDeps = plusInstalledModuleEnv plus_mod_dep emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, imp_direct_dep_mods = emptyInstalledModuleEnv, - imp_dep_direct_pkgs = S.empty, + imp_dep_direct_pkgs = emptyUniqDSet, imp_sig_mods = [], - imp_trust_pkgs = S.empty, + imp_trust_pkgs = emptyUniqDSet, imp_trust_own_pkg = False, imp_boot_mods = emptyInstalledModuleEnv, imp_orphs = [], @@ -1398,8 +1399,8 @@ plusImportAvails imp_orphs = orphs2, imp_finsts = finsts2 }) = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2, - imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, - imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, + imp_dep_direct_pkgs = ddpkgs1 `unionUniqDSets` ddpkgs2, + imp_trust_pkgs = tpkgs1 `unionUniqDSets` tpkgs2, imp_trust_own_pkg = tself1 || tself2, imp_boot_mods = srs1 `plusModDeps` srcs2, imp_sig_mods = unionListsOrd sig_mods1 sig_mods2, ===================================== compiler/GHC/Types/Unique/DSet.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Types.Unique.DSet ( isEmptyUniqDSet, lookupUniqDSet, uniqDSetToList, + uniqDSetToAscList, partitionUniqDSet, mapUniqDSet ) where @@ -43,8 +44,11 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique +import GHC.Utils.Binary + import Data.Coerce import Data.Data +import Data.List (sort) -- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. -- Beyond preserving invariants, we may also want to 'override' typeclass @@ -120,6 +124,9 @@ lookupUniqDSet = lookupUDFM . getUniqDSet uniqDSetToList :: UniqDSet a -> [a] uniqDSetToList = eltsUDFM . getUniqDSet +uniqDSetToAscList :: Ord a => UniqDSet a -> [a] +uniqDSetToAscList = sort . uniqDSetToList + partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet @@ -140,3 +147,7 @@ instance Outputable a => Outputable (UniqDSet a) where pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList + +instance (Uniquable a, Binary a) => Binary (UniqDSet a) where + put_ bh = put_ bh . uniqDSetToList + get bh = mkUniqDSet <$> get bh ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -81,6 +81,7 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic (pprPanic) +import GHC.Types.Unique.DSet import GHC.Unit.Module.ModIface import GHC.Unit.Module import qualified Data.Set as Set @@ -339,8 +340,8 @@ unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env -unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey -unitEnv_keys env = Map.keysSet (unitEnv_graph env) +unitEnv_keys :: UnitEnvGraph v -> UnitIdSet +unitEnv_keys env = mkUniqDSet $ Map.keys (unitEnv_graph env) unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)] unitEnv_elts env = Map.toList (unitEnv_graph env) @@ -443,7 +444,7 @@ ue_unitHomeUnit_maybe uid ue_env = ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env -ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId +ue_all_home_unit_ids :: UnitEnv -> UnitIdSet ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.State +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint import GHC.Utils.Binary @@ -53,13 +54,13 @@ data Dependencies = Deps -- ^ All home-package modules which are directly imported by this one. -- This may include modules from other units when using multiple home units - , dep_direct_pkgs :: Set UnitId + , dep_direct_pkgs :: UnitIdSet -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. -- Does not include other home units when using multiple home units. -- Modules from these units will go in `dep_direct_mods` - , dep_plugin_pkgs :: Set UnitId + , dep_plugin_pkgs :: UnitIdSet -- ^ All units needed for plugins ------------------------------------ @@ -69,7 +70,7 @@ data Dependencies = Deps -- ^ Transitive closure of hsig files in the home package - , dep_trusted_pkgs :: Set UnitId + , dep_trusted_pkgs :: UnitIdSet -- Packages which we are required to trust -- when the module is imported as a safe import -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names @@ -110,7 +111,7 @@ data Dependencies = Deps mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies mkDependencies home_unit mod imports plugin_mods = let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods - plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins) + plugin_units = mkUniqDSet (map (toUnitId . moduleUnit) external_plugins) all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot)) (imp_direct_dep_mods imports) (map (fmap toUnitId) home_plugins) @@ -197,12 +198,12 @@ instance Binary Dependencies where noDependencies :: Dependencies noDependencies = Deps - { dep_direct_mods = Set.empty - , dep_direct_pkgs = Set.empty - , dep_plugin_pkgs = Set.empty + { dep_direct_mods = mempty + , dep_direct_pkgs = emptyUniqDSet + , dep_plugin_pkgs = emptyUniqDSet , dep_sig_mods = [] - , dep_boot_mods = Set.empty - , dep_trusted_pkgs = Set.empty + , dep_boot_mods = mempty + , dep_trusted_pkgs = emptyUniqDSet , dep_orphs = [] , dep_finsts = [] } @@ -220,11 +221,11 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, text "boot module dependencies:" <+> ppr_set ppr bmods, - text "direct package dependencies:" <+> ppr_set ppr pkgs, - text "plugin package dependencies:" <+> ppr_set ppr plgns, - if null tps + text "direct package dependencies:" <+> ppr_unitIdSet ppr pkgs, + text "plugin package dependencies:" <+> ppr_unitIdSet ppr plgns, + if isEmptyUniqDSet tps then empty - else text "trusted package dependencies:" <+> ppr_set ppr tps, + else text "trusted package dependencies:" <+> ppr_unitIdSet ppr tps, text "orphans:" <+> fsep (map ppr orphs), text "family instance modules:" <+> fsep (map ppr finsts) ] @@ -235,6 +236,9 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc ppr_set w = fsep . fmap w . Set.toAscList + ppr_unitIdSet :: (UnitId -> SDoc) -> UnitIdSet -> SDoc + ppr_unitIdSet w = fsep . fmap w . sort . uniqDSetToList + -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance -- @@ -491,7 +495,7 @@ data ImportAvails imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot, -- ^ Home-package modules directly imported by the module being compiled. - imp_dep_direct_pkgs :: Set UnitId, + imp_dep_direct_pkgs :: UnitIdSet, -- ^ Packages directly needed by the module being compiled imp_trust_own_pkg :: Bool, @@ -502,7 +506,7 @@ data ImportAvails -- Transitive information below here - imp_trust_pkgs :: Set UnitId, + imp_trust_pkgs :: UnitIdSet, -- ^ This records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if ===================================== compiler/GHC/Unit/Module/ModGuts.hs ===================================== @@ -37,8 +37,6 @@ import GHC.Types.SourceFile ( HscSource(..), hscSourceToIsBoot ) import GHC.Types.SrcLoc import GHC.Types.CostCentre -import Data.Set (Set) - -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module @@ -137,7 +135,7 @@ data CgGuts cg_ccs :: [CostCentre], -- List of cost centres used in bindings and rules cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_foreign_files :: ![(ForeignSrcLang, FilePath)], - cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to + cg_dep_pkgs :: !UnitIdSet, -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -346,10 +346,10 @@ data UnitConfig = UnitConfig , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units - , unitConfigHomeUnits :: Set.Set UnitId + , unitConfigHomeUnits :: UnitIdSet } -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> UnitConfig initUnitConfig dflags cached_dbs home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags @@ -626,7 +626,7 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) initUnits logger dflags cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () @@ -1362,7 +1362,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> text db_path - forM_ (Set.toList override_set) $ \pkg -> + forM_ (uniqDSetToList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> text "overrides a previously defined package" @@ -1374,9 +1374,9 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] -- The set of UnitIds which appear in both db and pkgs. These are the -- ones that get overridden. Compute this just to give some -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) + override_set :: UnitIdSet + override_set = intersectUniqDSets (mkUniqDSet $ nonDetKeysUniqMap db_map) + (mkUniqDSet $ nonDetKeysUniqMap pkg_map) -- Now merge the sets together (NB: in case of duplicate, -- first argument preferred) @@ -1688,7 +1688,7 @@ mkUnitState logger cfg = do let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = uniqDSetToList home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map @@ -1701,15 +1701,15 @@ mkUnitState logger cfg = do } return (state, raw_dbs) -selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool -selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True +selectHptFlag :: UnitIdSet -> PackageFlag -> Bool +selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = True selectHptFlag _ _ = False -selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId -selectHomeUnits home_units flags = foldl' go Set.empty flags +selectHomeUnits :: UnitIdSet -> [PackageFlag] -> UnitIdSet +selectHomeUnits home_units flags = foldl' go emptyUniqDSet flags where - go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId - go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur + go :: UnitIdSet -> PackageFlag -> UnitIdSet + go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = addOneToUniqDSet cur (toUnitId uid) -- MP: This does not yet support thinning/renaming go cur _ = cur ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -33,6 +33,7 @@ module GHC.Unit.Types , GenInstantiatedUnit (..) , InstantiatedUnit , DefUnitId + , UnitIdSet , Instantiations , GenInstantiations , mkInstantiatedUnit @@ -538,6 +539,8 @@ pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- code for. type DefUnitId = Definite UnitId +type UnitIdSet = UniqDSet UnitId + unitIdString :: UnitId -> String unitIdString = unpackFS . unitIdFS ===================================== ghc/GHCi/UI.hs ===================================== @@ -105,6 +105,7 @@ import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Bag (unitBag) import qualified GHC.Data.Strict as Strict +import GHC.Types.Unique.DSet -- Haskell Libraries import System.Console.Haskeline as Haskeline @@ -125,7 +126,6 @@ import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.List.NonEmpty as NE -import qualified Data.Set as S import Data.Maybe import qualified Data.Map as M import Data.IntMap.Strict (IntMap) @@ -561,7 +561,7 @@ interactiveUI config srcs maybe_exprs = do -- Set to True because Prelude is implicitly imported. impDecl at ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}} hsc_env <- GHC.getSession - let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1 + let in_multi = sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 empty_cache <- liftIO newIfaceCache startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, @@ -2568,15 +2568,15 @@ isSafeModule m = do -- print info to user... liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") - when (not $ S.null good) + when (not $ isEmptyUniqDSet good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ - (intercalate ", " $ map (showPpr dflags) (S.toList good))) - case msafe && S.null bad of + (intercalate ", " $ map (showPpr dflags) (uniqDSetToList good))) + case msafe && isEmptyUniqDSet bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do - when (not $ null bad) + when (not $ isEmptyUniqDSet bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " - ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad))) + ++ (intercalate ", " $ map (showPpr dflags) (uniqDSetToList bad))) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where @@ -2586,8 +2586,8 @@ isSafeModule m = do | isHomeModule (hsc_home_unit hsc_env) md = True | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md) - tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty) - | otherwise = S.partition part deps + tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (emptyUniqDSet, emptyUniqDSet) + | otherwise = partitionUniqDSet part deps where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg unit_state = hsc_units hsc_env dflags = hsc_dflags hsc_env View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a2aaf8ea6d03fa3fc8760012a4cd57b1b0ca4fd7 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a2aaf8ea6d03fa3fc8760012a4cd57b1b0ca4fd7 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 14:13:47 2023 From: gitlab at gitlab.haskell.org (Sylvain Henry (@hsyl20)) Date: Tue, 02 May 2023 10:13:47 -0400 Subject: [Git][ghc/ghc][wip/js-boundsCheck] Split Addr# storage into arr and default array Message-ID: <64511a9b5129b_178e7416e167f8c27270d6@gitlab.mail> Sylvain Henry pushed to branch wip/js-boundsCheck at Glasgow Haskell Compiler / GHC Commits: 2e61bec7 by Sylvain Henry at 2023-05-02T16:18:32+02:00 Split Addr# storage into arr and default array Addr# were stored in "arr" sub-array as tuples [array,offset] We change this to store only the array in "arr" and the offset in the default array. - - - - - 9 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,219 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsCheckedRangeLen bound a1 o1 n - . boundsCheckedRangeLen bound a2 o2 n + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsCheckedRangeLen bound a1 o1 n - . boundsCheckedRangeLen bound a2 o2 n - . checkOverlapByteArray bound a1 o1 a2 o2 n - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsCheckedRangeLen bound a o n $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -757,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -918,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ r |= var "h$threads" - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ r |= var "h$threads" + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1032,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsCheckedLen bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsCheckedLen bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsCheckedLen bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsCheckedLen bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsCheckedLen bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1368,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1392,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1407,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1417,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1432,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1445,73 +1387,151 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked' +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound :: JExpr -- ^ Max index expression -> Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Index -> JStat -- ^ Result -> JStat -boundsChecked' _ False _ r = r -boundsChecked' max_index True i r = - ifS ((i .>=. zero_) .&&. (i .<. max_index)) r $ - returnS (app "h$exitProcess" [Int 134]) +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] -- | Bounds checking using ".length" property (Arrays) -boundsChecked +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index + -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -boundsChecked do_check arr = boundsChecked' (arr .^ "length") do_check +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) -- | Bounds checking using ".len" property (ByteArrays) -boundsCheckedLen +bnd_ba :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index -> JStat -- ^ Result -> JStat -boundsCheckedLen do_check arr = boundsChecked' (arr .^ "len") do_check +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r -- | Bounds checking on a range and using ".len" property (ByteArrays) -- -- Empty ranges trivially pass the check -boundsCheckedRangeLen +bnd_ba_range :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -boundsCheckedRangeLen False _ _ _ r = r -boundsCheckedRangeLen True xs i n r = +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ - ifS (n .===. zero_) -- We can always fill zero elements, even if it seems out-of-bounds + -- Empty ranges trivially pass the check + ifS (n .===. zero_) r - (boundsCheckedLen True xs (Add i (Sub n 1)) (boundsCheckedLen True xs i r)) + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) checkOverlapByteArray :: Bool -- ^ Should we do bounds checking? @@ -1522,20 +1542,18 @@ checkOverlapByteArray -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray False _ _ _ _ _ r = r checkOverlapByteArray True a1 o1 a2 o2 n r = ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) -byteIndex16 :: JExpr -> JExpr -byteIndex16 i = Add 1 (Mul 2 i) - -byteIndex32 :: JExpr -> JExpr -byteIndex32 i = Add 3 (Mul 4 i) - -byteIndex64 :: JExpr -> JExpr -byteIndex64 i = Add 7 (Mul 8 i) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; return true; } ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(21142), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2e61bec70c36af6e459fa7a73e93d1be29192610 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2e61bec70c36af6e459fa7a73e93d1be29192610 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 14:15:57 2023 From: gitlab at gitlab.haskell.org (Sylvain Henry (@hsyl20)) Date: Tue, 02 May 2023 10:15:57 -0400 Subject: [Git][ghc/ghc][wip/js-boundsCheck] 42 commits: JS: fix thread-related primops Message-ID: <64511b1dc3ad1_178e7416e237d902728021@gitlab.mail> Sylvain Henry pushed to branch wip/js-boundsCheck at Glasgow Haskell Compiler / GHC Commits: d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 0646d828 by Josh Meredith at 2023-05-02T16:19:46+02:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 081b9d44 by Sylvain Henry at 2023-05-02T16:21:05+02:00 Split Addr# storage into arr and default array Addr# were stored in "arr" sub-array as tuples [array,offset] We change this to store only the array in "arr" and the offset in the default array. - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - + compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/Stg/Debug.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e61bec70c36af6e459fa7a73e93d1be29192610...081b9d44742ad212dfacd855e16f239c91ccfa9f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e61bec70c36af6e459fa7a73e93d1be29192610...081b9d44742ad212dfacd855e16f239c91ccfa9f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 14:56:17 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Tue, 02 May 2023 10:56:17 -0400 Subject: [Git][ghc/ghc][wip/unitidset] WIP refactor `Set UnitId` to `UniqDSet UnitId` Message-ID: <64512491a96d8_3c91159795054895@gitlab.mail> Josh Meredith pushed to branch wip/unitidset at Glasgow Haskell Compiler / GHC Commits: e398305c by Josh Meredith at 2023-05-02T14:55:57+00:00 WIP refactor `Set UnitId` to `UniqDSet UnitId` - - - - - 21 changed files: - compiler/GHC.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Types/Unique/DSet.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -395,6 +395,7 @@ import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -418,8 +419,6 @@ import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as S import qualified Data.Sequence as Seq import System.Directory @@ -604,7 +603,7 @@ setSessionDynFlags dflags0 = do logger <- getLogger dflags <- checkNewDynFlags logger dflags0 let all_uids = hsc_all_home_unit_ids hsc_env - case S.toList all_uids of + case uniqDSetToList all_uids of [uid] -> do setUnitDynFlagsNoCheck uid dflags modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags)) @@ -1379,7 +1378,7 @@ data ModuleInfo = ModuleInfo { -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do - if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env + if moduleUnitId mdl `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env then liftIO $ getHomeModuleInfo hsc_env mdl else liftIO $ getPackageModuleInfo hsc_env mdl @@ -1756,7 +1755,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, UnitIdSet) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -56,12 +56,11 @@ import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) +import GHC.Types.Unique.DSet import System.Directory import System.FilePath import System.IO -import Data.Set (Set) -import qualified Data.Set as Set {- ************************************************************************ @@ -84,7 +83,7 @@ codeOutput -> (a -> ForeignStubs) -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with the C compiler - -> Set UnitId -- ^ Dependencies + -> UnitIdSet -- ^ Dependencies -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), @@ -161,11 +160,11 @@ outputC :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a - -> Set UnitId + -> UnitIdSet -> IO a outputC logger dflags filenm cmm_stream unit_deps = withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do - let pkg_names = map unitIdString (Set.toAscList unit_deps) + let pkg_names = map unitIdString (uniqDSetToAscList unit_deps) doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h "#include \"Stg.h\"\n" ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -127,7 +127,7 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env -hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId +hsc_all_home_unit_ids :: HscEnv -> UnitIdSet hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -245,6 +245,7 @@ import GHC.Types.Name.Ppr import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic @@ -274,7 +275,6 @@ import Data.IORef import System.FilePath as FilePath import System.Directory import qualified Data.Set as S -import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) @@ -1457,15 +1457,15 @@ checkSafeImports tcg_env clearDiagnostics -- Check safe imports are correct - safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safePkgs <- mkUniqDSet <$> mapMaybeM checkSafe safeImps safeErrs <- getDiagnostics clearDiagnostics -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyMessages, S.empty) - True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + False -> return (emptyMessages, emptyUniqDSet) + True -> do infPkgs <- mkUniqDSet <$> mapMaybeM checkSafe regImps infErrs <- getDiagnostics clearDiagnostics return (infErrs, infPkgs) @@ -1516,12 +1516,12 @@ checkSafeImports tcg_env checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> + pkgTrustReqs :: DynFlags -> UnitIdSet -> UnitIdSet -> Bool -> ImportAvails pkgTrustReqs dflags req inf infPassed | safeInferOn dflags && not (safeHaskellModeEnabled dflags) && infPassed = emptyImportAvails { - imp_trust_pkgs = req `S.union` inf + imp_trust_pkgs = req `unionUniqDSets` inf } pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe = emptyImportAvails @@ -1540,12 +1540,12 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyMessages errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, UnitIdSet) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l good <- isEmptyMessages `fmap` getDiagnostics clearDiagnostics -- don't want them printed... - let pkgs' | Just p <- self = S.insert p pkgs + let pkgs' | Just p <- self = addOneToUniqDSet pkgs p | otherwise = pkgs return (good, pkgs') @@ -1554,7 +1554,7 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe UnitId, Set UnitId) + -> Hsc (Maybe UnitId, UnitIdSet) hscCheckSafe' m l = do hsc_env <- getHscEnv let home_unit = hsc_home_unit hsc_env @@ -1566,7 +1566,7 @@ hscCheckSafe' m l = do -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) where - isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) + isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, UnitIdSet) isModSafe home_unit m l = do hsc_env <- getHscEnv dflags <- getDynFlags @@ -1648,10 +1648,10 @@ hscCheckSafe' m l = do -- | Check the list of packages are trusted. -checkPkgTrust :: Set UnitId -> Hsc () +checkPkgTrust :: UnitIdSet -> Hsc () checkPkgTrust pkgs = do hsc_env <- getHscEnv - let errors = S.foldr go emptyBag pkgs + let errors = foldr go emptyBag $ uniqDSetToAscList pkgs state = hsc_units hsc_env go pkg acc | unitIsTrusted $ unsafeLookupUnitId state pkg @@ -1699,7 +1699,7 @@ markUnsafeInfer tcg_env whyUnsafe = do False -> return tcg_env where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = emptyUniqDSet } pprMod = ppr $ moduleName $ tcg_mod tcg_env whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" @@ -2060,7 +2060,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs in NoStubs `appendStubC` ip_init | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] emptyUniqDSet rawCmms return stub_c_exists where ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -107,6 +107,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Types.PkgQual import GHC.Unit @@ -490,7 +491,7 @@ load how_much = loadWithCache noIfaceCache how_much mkBatchMsg :: HscEnv -> Messager mkBatchMsg hsc_env = - if length (hsc_all_home_unit_ids hsc_env) > 1 + if sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 -- This also displays what unit each module is from. then batchMultiMsg else batchMsg @@ -1735,25 +1736,25 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages] +checkHomeUnitsClosed :: UnitEnv -> UnitIdSet -> [(UnitId, UnitId)] -> [DriverMessages] -- Fast path, trivially closed. checkHomeUnitsClosed ue home_id_set home_imp_ids - | Set.size home_id_set == 1 = [] + | sizeUniqDSet home_id_set == 1 = [] | otherwise = - let res = foldMap loop home_imp_ids + let res = foldr (\ids acc -> unionUniqDSets acc $ loop ids) emptyUniqDSet home_imp_ids -- Now check whether everything which transitively depends on a home_unit is actually a home_unit -- These units are the ones which we need to load as home packages but failed to do for some reason, -- it's a bug in the tool invoking GHC. - bad_unit_ids = Set.difference res home_id_set - in if Set.null bad_unit_ids + bad_unit_ids = res `minusUniqDSet` home_id_set + in if isEmptyUniqDSet bad_unit_ids then [] - else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (uniqDSetToAscList bad_unit_ids)] where rootLoc = mkGeneralSrcSpan (fsLit "") -- TODO: This could repeat quite a bit of work but I struggled to write this function. -- Which units transitively depend on a home unit - loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit + loop :: (UnitId, UnitId) -> UnitIdSet -- The units which transitively depend on a home unit loop (from_uid, uid) = let us = ue_findHomeUnitEnv from_uid ue in let um = unitInfoMap (homeUnitEnv_units us) in @@ -1761,20 +1762,21 @@ checkHomeUnitsClosed ue home_id_set home_imp_ids Nothing -> pprPanic "uid not found" (ppr uid) Just ui -> let depends = unitDepends ui - home_depends = Set.fromList depends `Set.intersection` home_id_set - other_depends = Set.fromList depends `Set.difference` home_id_set + home_depends = mkUniqDSet depends `intersectUniqDSets` home_id_set + other_depends = mkUniqDSet depends `minusUniqDSet` home_id_set in -- Case 1: The unit directly depends on a home_id - if not (null home_depends) + if not (isEmptyUniqDSet home_depends) then - let res = foldMap (loop . (from_uid,)) other_depends - in Set.insert uid res + let res :: UnitIdSet + res = foldr (\ide acc -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends + in addOneToUniqDSet res uid -- Case 2: Check the rest of the dependencies, and then see if any of them depended on else - let res = foldMap (loop . (from_uid,)) other_depends + let res = foldr (\ide acc -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends in - if not (Set.null res) - then Set.insert uid res + if not (isEmptyUniqDSet res) + then addOneToUniqDSet res uid else res -- | Update the every ModSummary that is depended on ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -108,6 +108,7 @@ import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.SourceError +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -125,7 +126,6 @@ import Control.Monad import qualified Control.Monad.Catch as MC (handle) import Data.Maybe import Data.Either ( partitionEithers ) -import qualified Data.Set as Set import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp @@ -408,8 +408,8 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt home_mod_infos = eltsHpt hpt -- the packages we depend on - pkg_deps = Set.toList - $ Set.unions + pkg_deps = uniqDSetToAscList + $ unionManyUniqDSets $ fmap (dep_direct_pkgs . mi_deps . hm_iface) $ home_mod_infos ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -40,7 +41,6 @@ import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.Set as Set import GHC.Linker.Types import GHC.Unit.Finder @@ -196,7 +196,7 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do mk_mod_usage_info :: UsageConfig -> HomeUnit - -> Set.Set UnitId + -> UnitIdSet -> Module -> ImportedMods -> NameSet @@ -255,7 +255,7 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names -- (need to recompile if its export list changes: export_fprint) mkUsage :: Module -> ModIface -> Maybe Usage mkUsage mod iface - | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids + | not $ toUnitId (moduleUnit mod) `elementOfUniqDSet` home_unit_ids = Just $ UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -504,7 +504,7 @@ loadInterface doc_str mod from -- overlapping instances. ; massertPpr ((isOneShot (ghcMode (hsc_dflags hsc_env))) - || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env + || not (moduleUnitId mod `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env) || mod == gHC_PRIM) (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique.Set import GHC.Types.Fixity.Env import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State @@ -617,8 +618,8 @@ checkDependencies hsc_env summary iface all_home_units = hsc_all_home_unit_ids hsc_env units = hsc_units hsc_env prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) - prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) - (dep_plugin_pkgs (mi_deps iface))) + prev_dep_pkgs = uniqDSetToAscList (unionUniqDSets (dep_direct_pkgs (mi_deps iface)) + (dep_plugin_pkgs (mi_deps iface))) implicit_deps = map (fsLit "Implicit",) (implicitPackageDeps dflags) @@ -633,7 +634,7 @@ checkDependencies hsc_env summary iface classify _ (Found _ mod) - | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) + | (toUnitId $ moduleUnit mod) `elementOfUniqDSet` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -324,20 +324,20 @@ loadCmdLineLibs interp hsc_env = do loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState loadCmdLineLibs' interp hsc_env pls = snd <$> foldM - (\(done', pls') cur_uid -> load done' cur_uid pls') - (Set.empty, pls) - (hsc_all_home_unit_ids hsc_env) + (\(done', pls') cur_uid -> load done' cur_uid pls') + (emptyUniqDSet, pls) + (uniqDSetToList $ hsc_all_home_unit_ids hsc_env) where - load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState) - load done uid pls | uid `Set.member` done = return (done, pls) + load :: UnitIdSet -> UnitId -> LoaderState -> IO (UnitIdSet, LoaderState) + load done uid pls | uid `elementOfUniqDSet` done = return (done, pls) load done uid pls = do let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (homeUnitDepends (hsc_units hsc')) pls'' <- loadCmdLineLibs'' interp hsc' pls' - return $ (Set.insert uid done', pls'') + return $ (addOneToUniqDSet done' uid, pls'') loadCmdLineLibs'' :: Interp @@ -685,7 +685,7 @@ getLinkDeps :: HscEnv -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first + -> IO ([Linkable], [Linkable], [UnitId], UnitIdSet) -- ... then link these first -- The module and package dependencies for the needed modules are returned. -- See Note [Object File Dependencies] -- Fails with an IO exception if it can't find enough files @@ -737,7 +737,7 @@ getLinkDeps hsc_env pls replace_osuf span mods -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop :: (UnitIdSet, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UnitIdSet, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts @@ -766,7 +766,7 @@ getLinkDeps hsc_env pls replace_osuf span mods HsBootFile -> link_boot_mod_error (mi_module iface) _ -> return $ Just (mi_module iface) - in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod + in (dep_direct_pkgs (mi_deps iface),) <$> mmod Nothing -> let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid in throwGhcExceptionIO (ProgramError (showSDoc dflags err)) @@ -780,9 +780,9 @@ getLinkDeps hsc_env pls replace_osuf span mods -- dependencies of that. Hence we need to traverse the dependency -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow - -> UniqDSet Module -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([Module], UniqDSet UnitId) -- result + -> UniqDSet Module -- accum. module dependencies + -> UnitIdSet -- accum. package dependencies + -> IO ([Module], UnitIdSet) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -814,7 +814,7 @@ getLinkDeps hsc_env pls replace_osuf span mods acc_mods' = case hsc_home_unit_maybe hsc_env of Nothing -> acc_mods Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs (uniqDSetToList pkg_deps) case hsc_home_unit_maybe hsc_env of Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -37,7 +37,7 @@ module GHC.Linker.Types where import GHC.Prelude -import GHC.Unit ( UnitId, Module ) +import GHC.Unit ( UnitId, Module, UnitIdSet ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) import GHCi.RemoteTypes ( ForeignHValue ) @@ -53,7 +53,6 @@ import Control.Concurrent.MVar import Data.Time ( UTCTime ) import Data.Maybe import GHC.Unit.Module.Env -import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM import GHC.Unit.Module.WholeCoreBindings @@ -146,7 +145,7 @@ data LoadedPkgInfo { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] - , loaded_pkg_trans_deps :: UniqDSet UnitId + , loaded_pkg_trans_deps :: UnitIdSet } instance Outputable LoadedPkgInfo where ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -75,6 +75,7 @@ import GHC.Types.HpcInfo import GHC.Types.Error import GHC.Types.PkgQual import GHC.Types.GREInfo (ConInfo(..)) +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Module.Warnings @@ -213,8 +214,8 @@ rnImports imports = do let merged_import_avail = clobberSourceImports imp_avails dflags <- getDynFlags let final_import_avail = - merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags) - `S.union` imp_dep_direct_pkgs merged_import_avail} + merged_import_avail { imp_dep_direct_pkgs = mkUniqDSet (implicitPackageDeps dflags) + `unionUniqDSets` imp_dep_direct_pkgs merged_import_avail} return (decls, rdr_env, final_import_avail, hpc_usage) where @@ -494,7 +495,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit - -> S.Set UnitId + -> UnitIdSet -> ModIface -> IsSafeImport -> IsBootInterface @@ -549,7 +550,7 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by -- Trusted packages are a lot like orphans. trusted_pkgs | mod_safe' = dep_trusted_pkgs deps - | otherwise = S.empty + | otherwise = emptyUniqDSet pkg = moduleUnit (mi_module iface) @@ -562,11 +563,11 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by | isHomeUnit home_unit pkg = ptrust | otherwise = False - dependent_pkgs = if toUnitId pkg `S.member` other_home_units - then S.empty - else S.singleton ipkg + dependent_pkgs = if toUnitId pkg `elementOfUniqDSet` other_home_units + then emptyUniqDSet + else unitUniqDSet ipkg - direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units + direct_mods = mkModDeps $ if toUnitId pkg `elementOfUniqDSet` other_home_units then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) else S.empty ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -148,6 +148,7 @@ import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -185,7 +186,6 @@ import Data.List ( sortBy, sort ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.Ord -import qualified Data.Set as S import Data.Traversable ( for ) @@ -3134,7 +3134,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , text "Dependent modules:" <+> (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_direct_pkgs imports)] + ppr (uniqDSetToAscList $ imp_dep_direct_pkgs imports)] -- The use of sort is just to reduce unnecessary -- wobbling in testsuite output ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -142,6 +142,7 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo @@ -1367,9 +1368,9 @@ plusModDeps = plusInstalledModuleEnv plus_mod_dep emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, imp_direct_dep_mods = emptyInstalledModuleEnv, - imp_dep_direct_pkgs = S.empty, + imp_dep_direct_pkgs = emptyUniqDSet, imp_sig_mods = [], - imp_trust_pkgs = S.empty, + imp_trust_pkgs = emptyUniqDSet, imp_trust_own_pkg = False, imp_boot_mods = emptyInstalledModuleEnv, imp_orphs = [], @@ -1398,8 +1399,8 @@ plusImportAvails imp_orphs = orphs2, imp_finsts = finsts2 }) = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2, - imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, - imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, + imp_dep_direct_pkgs = ddpkgs1 `unionUniqDSets` ddpkgs2, + imp_trust_pkgs = tpkgs1 `unionUniqDSets` tpkgs2, imp_trust_own_pkg = tself1 || tself2, imp_boot_mods = srs1 `plusModDeps` srcs2, imp_sig_mods = unionListsOrd sig_mods1 sig_mods2, ===================================== compiler/GHC/Types/Unique/DSet.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Types.Unique.DSet ( isEmptyUniqDSet, lookupUniqDSet, uniqDSetToList, + uniqDSetToAscList, partitionUniqDSet, mapUniqDSet ) where @@ -43,8 +44,11 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique +import GHC.Utils.Binary + import Data.Coerce import Data.Data +import Data.List (sort) -- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. -- Beyond preserving invariants, we may also want to 'override' typeclass @@ -120,6 +124,9 @@ lookupUniqDSet = lookupUDFM . getUniqDSet uniqDSetToList :: UniqDSet a -> [a] uniqDSetToList = eltsUDFM . getUniqDSet +uniqDSetToAscList :: Ord a => UniqDSet a -> [a] +uniqDSetToAscList = sort . uniqDSetToList + partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet @@ -140,3 +147,7 @@ instance Outputable a => Outputable (UniqDSet a) where pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList + +instance (Uniquable a, Binary a) => Binary (UniqDSet a) where + put_ bh = put_ bh . uniqDSetToAscList + get bh = mkUniqDSet <$> get bh ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -81,6 +81,7 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic (pprPanic) +import GHC.Types.Unique.DSet import GHC.Unit.Module.ModIface import GHC.Unit.Module import qualified Data.Set as Set @@ -339,8 +340,8 @@ unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env -unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey -unitEnv_keys env = Map.keysSet (unitEnv_graph env) +unitEnv_keys :: UnitEnvGraph v -> UnitIdSet +unitEnv_keys env = mkUniqDSet $ Map.keys (unitEnv_graph env) unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)] unitEnv_elts env = Map.toList (unitEnv_graph env) @@ -443,7 +444,7 @@ ue_unitHomeUnit_maybe uid ue_env = ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env -ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId +ue_all_home_unit_ids :: UnitEnv -> UnitIdSet ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.State +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint import GHC.Utils.Binary @@ -53,13 +54,13 @@ data Dependencies = Deps -- ^ All home-package modules which are directly imported by this one. -- This may include modules from other units when using multiple home units - , dep_direct_pkgs :: Set UnitId + , dep_direct_pkgs :: UnitIdSet -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. -- Does not include other home units when using multiple home units. -- Modules from these units will go in `dep_direct_mods` - , dep_plugin_pkgs :: Set UnitId + , dep_plugin_pkgs :: UnitIdSet -- ^ All units needed for plugins ------------------------------------ @@ -69,7 +70,7 @@ data Dependencies = Deps -- ^ Transitive closure of hsig files in the home package - , dep_trusted_pkgs :: Set UnitId + , dep_trusted_pkgs :: UnitIdSet -- Packages which we are required to trust -- when the module is imported as a safe import -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names @@ -110,7 +111,7 @@ data Dependencies = Deps mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies mkDependencies home_unit mod imports plugin_mods = let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods - plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins) + plugin_units = mkUniqDSet (map (toUnitId . moduleUnit) external_plugins) all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot)) (imp_direct_dep_mods imports) (map (fmap toUnitId) home_plugins) @@ -197,12 +198,12 @@ instance Binary Dependencies where noDependencies :: Dependencies noDependencies = Deps - { dep_direct_mods = Set.empty - , dep_direct_pkgs = Set.empty - , dep_plugin_pkgs = Set.empty + { dep_direct_mods = mempty + , dep_direct_pkgs = emptyUniqDSet + , dep_plugin_pkgs = emptyUniqDSet , dep_sig_mods = [] - , dep_boot_mods = Set.empty - , dep_trusted_pkgs = Set.empty + , dep_boot_mods = mempty + , dep_trusted_pkgs = emptyUniqDSet , dep_orphs = [] , dep_finsts = [] } @@ -220,11 +221,11 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, text "boot module dependencies:" <+> ppr_set ppr bmods, - text "direct package dependencies:" <+> ppr_set ppr pkgs, - text "plugin package dependencies:" <+> ppr_set ppr plgns, - if null tps + text "direct package dependencies:" <+> ppr_unitIdSet ppr pkgs, + text "plugin package dependencies:" <+> ppr_unitIdSet ppr plgns, + if isEmptyUniqDSet tps then empty - else text "trusted package dependencies:" <+> ppr_set ppr tps, + else text "trusted package dependencies:" <+> ppr_unitIdSet ppr tps, text "orphans:" <+> fsep (map ppr orphs), text "family instance modules:" <+> fsep (map ppr finsts) ] @@ -235,6 +236,9 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc ppr_set w = fsep . fmap w . Set.toAscList + ppr_unitIdSet :: (UnitId -> SDoc) -> UnitIdSet -> SDoc + ppr_unitIdSet w = fsep . fmap w . sort . uniqDSetToList + -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance -- @@ -491,7 +495,7 @@ data ImportAvails imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot, -- ^ Home-package modules directly imported by the module being compiled. - imp_dep_direct_pkgs :: Set UnitId, + imp_dep_direct_pkgs :: UnitIdSet, -- ^ Packages directly needed by the module being compiled imp_trust_own_pkg :: Bool, @@ -502,7 +506,7 @@ data ImportAvails -- Transitive information below here - imp_trust_pkgs :: Set UnitId, + imp_trust_pkgs :: UnitIdSet, -- ^ This records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if ===================================== compiler/GHC/Unit/Module/ModGuts.hs ===================================== @@ -37,8 +37,6 @@ import GHC.Types.SourceFile ( HscSource(..), hscSourceToIsBoot ) import GHC.Types.SrcLoc import GHC.Types.CostCentre -import Data.Set (Set) - -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module @@ -137,7 +135,7 @@ data CgGuts cg_ccs :: [CostCentre], -- List of cost centres used in bindings and rules cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_foreign_files :: ![(ForeignSrcLang, FilePath)], - cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to + cg_dep_pkgs :: !UnitIdSet, -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -346,10 +346,10 @@ data UnitConfig = UnitConfig , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units - , unitConfigHomeUnits :: Set.Set UnitId + , unitConfigHomeUnits :: UnitIdSet } -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> UnitConfig initUnitConfig dflags cached_dbs home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags @@ -626,7 +626,7 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) initUnits logger dflags cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () @@ -1362,7 +1362,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> text db_path - forM_ (Set.toList override_set) $ \pkg -> + forM_ (uniqDSetToList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> text "overrides a previously defined package" @@ -1374,9 +1374,9 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] -- The set of UnitIds which appear in both db and pkgs. These are the -- ones that get overridden. Compute this just to give some -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) + override_set :: UnitIdSet + override_set = intersectUniqDSets (mkUniqDSet $ nonDetKeysUniqMap db_map) + (mkUniqDSet $ nonDetKeysUniqMap pkg_map) -- Now merge the sets together (NB: in case of duplicate, -- first argument preferred) @@ -1688,7 +1688,7 @@ mkUnitState logger cfg = do let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = uniqDSetToList home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map @@ -1701,15 +1701,15 @@ mkUnitState logger cfg = do } return (state, raw_dbs) -selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool -selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True +selectHptFlag :: UnitIdSet -> PackageFlag -> Bool +selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = True selectHptFlag _ _ = False -selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId -selectHomeUnits home_units flags = foldl' go Set.empty flags +selectHomeUnits :: UnitIdSet -> [PackageFlag] -> UnitIdSet +selectHomeUnits home_units flags = foldl' go emptyUniqDSet flags where - go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId - go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur + go :: UnitIdSet -> PackageFlag -> UnitIdSet + go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = addOneToUniqDSet cur (toUnitId uid) -- MP: This does not yet support thinning/renaming go cur _ = cur ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -33,6 +33,7 @@ module GHC.Unit.Types , GenInstantiatedUnit (..) , InstantiatedUnit , DefUnitId + , UnitIdSet , Instantiations , GenInstantiations , mkInstantiatedUnit @@ -538,6 +539,8 @@ pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- code for. type DefUnitId = Definite UnitId +type UnitIdSet = UniqDSet UnitId + unitIdString :: UnitId -> String unitIdString = unpackFS . unitIdFS ===================================== ghc/GHCi/UI.hs ===================================== @@ -105,6 +105,7 @@ import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Bag (unitBag) import qualified GHC.Data.Strict as Strict +import GHC.Types.Unique.DSet -- Haskell Libraries import System.Console.Haskeline as Haskeline @@ -125,7 +126,6 @@ import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.List.NonEmpty as NE -import qualified Data.Set as S import Data.Maybe import qualified Data.Map as M import Data.IntMap.Strict (IntMap) @@ -561,7 +561,7 @@ interactiveUI config srcs maybe_exprs = do -- Set to True because Prelude is implicitly imported. impDecl at ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}} hsc_env <- GHC.getSession - let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1 + let in_multi = sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 empty_cache <- liftIO newIfaceCache startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, @@ -2568,15 +2568,15 @@ isSafeModule m = do -- print info to user... liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") - when (not $ S.null good) + when (not $ isEmptyUniqDSet good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ - (intercalate ", " $ map (showPpr dflags) (S.toList good))) - case msafe && S.null bad of + (intercalate ", " $ map (showPpr dflags) (uniqDSetToList good))) + case msafe && isEmptyUniqDSet bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do - when (not $ null bad) + when (not $ isEmptyUniqDSet bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " - ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad))) + ++ (intercalate ", " $ map (showPpr dflags) (uniqDSetToList bad))) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where @@ -2586,8 +2586,8 @@ isSafeModule m = do | isHomeModule (hsc_home_unit hsc_env) md = True | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md) - tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty) - | otherwise = S.partition part deps + tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (emptyUniqDSet, emptyUniqDSet) + | otherwise = partitionUniqDSet part deps where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg unit_state = hsc_units hsc_env dflags = hsc_dflags hsc_env View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e398305cf56890538eedaa0da43d3d8f98c5b197 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e398305cf56890538eedaa0da43d3d8f98c5b197 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 16:08:11 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Tue, 02 May 2023 12:08:11 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/supersven/riscv-increase-CI-happiness Message-ID: <6451356b117f4_3c911551f401036ce@gitlab.mail> Sven Tennie pushed new branch wip/supersven/riscv-increase-CI-happiness at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/supersven/riscv-increase-CI-happiness You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 19:36:54 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 02 May 2023 15:36:54 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/T19146 Message-ID: <6451665678426_3c911551dd81267c4@gitlab.mail> Ben Gamari pushed new branch wip/T19146 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T19146 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 19:38:30 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 02 May 2023 15:38:30 -0400 Subject: [Git][ghc/ghc][wip/T19146] 2 commits: rts: Don't sanity-check StgTSO.global_link Message-ID: <645166b644b2a_3c911551e001287b2@gitlab.mail> Ben Gamari pushed to branch wip/T19146 at Glasgow Haskell Compiler / GHC Commits: b5382516 by Ben Gamari at 2023-05-02T15:38:25-04:00 rts: Don't sanity-check StgTSO.global_link See Note [Avoid dangling global_link pointers]. Fixes #19146. - - - - - d2bcf347 by Ben Gamari at 2023-05-02T15:38:25-04:00 rts: Introduce printGlobalThreads - - - - - 4 changed files: - rts/Threads.c - rts/Threads.h - rts/sm/Evac.c - rts/sm/Sanity.c Changes: ===================================== rts/Threads.c ===================================== @@ -1008,6 +1008,20 @@ printAllThreads(void) } } +void +printGlobalThreads(void) +{ + for (uint32_t g = 0; g < RtsFlags.GcFlags.generations; g++) { + debugBelch("\ngen %d\n", g); + for (StgTSO *t = generations[g].threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu)\n", t, t->id); + } + for (StgTSO *t = generations[g].old_threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu) (old)\n", t, t->id); + } + } +} + // useful from gdb void printThreadQueue(StgTSO *t) ===================================== rts/Threads.h ===================================== @@ -43,6 +43,7 @@ W_ threadStackUnderflow (Capability *cap, StgTSO *tso); bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value); #if defined(DEBUG) +void printGlobalThreads(void); void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); void printAllThreads (void); ===================================== rts/sm/Evac.c ===================================== @@ -1030,8 +1030,10 @@ loop: return; case TSO: + { copy(p,info,q,sizeofW(StgTSO),gen_no); return; + } case STACK: { ===================================== rts/sm/Sanity.c ===================================== @@ -737,6 +737,27 @@ checkSTACK (StgStack *stack) checkStackChunk(sp, stack_end); } +/* + * Note [Avoid dangling global_link pointers] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * TSOs are a bit odd in that they have a global_link pointer field + * which is not scavenged by the GC. This field is used to track the + * generations[_].[old_]threads lists and is ultimately updated by + * MarkWeak.c:tidyThreadList. + + * Typically the fact that this field is not scavenged is fine as all reachable + * TSOs on the heap are guaranteed to be on some generation's thread list and + * therefore will be scavenged by tidyThreadList. However, the sanity checker + * poses a bit of a challenge here as it walks heap blocks directly and + * therefore may encounter TSOs which aren't reachable via the heap. + * For this reason, checkTSO does not check global_link. Instead, we only do + * so in checkGlobalTSOList, which by definition will only look at + * threads which are reachable via a thread list (and therefore must have won + * the forwarding-pointer race). + * + * See #19146. + */ + void checkTSO(StgTSO *tso) { @@ -761,9 +782,11 @@ checkTSO(StgTSO *tso) ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->stackobj)); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && - (tso->global_link == END_TSO_QUEUE || - get_itbl((StgClosure*)tso->global_link)->type == TSO)); + + // This assertion is sadly not viable. See Note [Sanity-checking global_link]. + //ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && + // (tso->global_link == END_TSO_QUEUE || + // get_itbl((StgClosure*)tso->global_link)->type == TSO)); if (tso->label) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->label)); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/708c5eba210deb951b1ab130a84fd67ebb76318d...d2bcf3472a825bafc11e90b5e5f8b8d40cd6bc67 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/708c5eba210deb951b1ab130a84fd67ebb76318d...d2bcf3472a825bafc11e90b5e5f8b8d40cd6bc67 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 19:49:52 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 02 May 2023 15:49:52 -0400 Subject: [Git][ghc/ghc][wip/T19146] 3 commits: rts: Assert that pointers aren't cleared Message-ID: <645169603a36a_3c911551f401343f8@gitlab.mail> Ben Gamari pushed to branch wip/T19146 at Glasgow Haskell Compiler / GHC Commits: 83b58e1a by Ben Gamari at 2023-05-02T15:49:39-04:00 rts: Assert that pointers aren't cleared This turns many segmentation faults into much easier-to-debug assertion failures by ensuring that LOOKS_LIKE_*_PTR checks recognize bit-patterns produced by `+RTS -DZ` clearing as invalid pointers. This is a bit ad-hoc but this is the debug runtime. - - - - - a41e2a77 by Ben Gamari at 2023-05-02T15:49:43-04:00 rts: Don't sanity-check StgTSO.global_link See Note [Avoid dangling global_link pointers]. Fixes #19146. - - - - - 593058d2 by Ben Gamari at 2023-05-02T15:49:44-04:00 rts: Introduce printGlobalThreads - - - - - 7 changed files: - rts/Threads.c - rts/Threads.h - rts/include/Cmm.h - rts/include/MachDeps.h - rts/include/rts/storage/ClosureMacros.h - rts/sm/Evac.c - rts/sm/Sanity.c Changes: ===================================== rts/Threads.c ===================================== @@ -1008,6 +1008,20 @@ printAllThreads(void) } } +void +printGlobalThreads(void) +{ + for (uint32_t g = 0; g < RtsFlags.GcFlags.generations; g++) { + debugBelch("\ngen %d\n", g); + for (StgTSO *t = generations[g].threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu)\n", t, t->id); + } + for (StgTSO *t = generations[g].old_threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu) (old)\n", t, t->id); + } + } +} + // useful from gdb void printThreadQueue(StgTSO *t) ===================================== rts/Threads.h ===================================== @@ -43,6 +43,7 @@ W_ threadStackUnderflow (Capability *cap, StgTSO *tso); bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value); #if defined(DEBUG) +void printGlobalThreads(void); void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); void printAllThreads (void); ===================================== rts/include/Cmm.h ===================================== @@ -605,16 +605,20 @@ #define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK) #define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT) +#define LOOKS_LIKE_PTR(p) ((p) != NULL && (p) != INVALID_GHC_POINTER) + /* Debugging macros */ #define LOOKS_LIKE_INFO_PTR(p) \ - ((p) != NULL && \ + (LOOKS_LIKE_PTR(p) && \ LOOKS_LIKE_INFO_PTR_NOT_NULL(p)) #define LOOKS_LIKE_INFO_PTR_NOT_NULL(p) \ ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) && \ (TO_W_(%INFO_TYPE(%STD_INFO(p))) < N_CLOSURE_TYPES)) -#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) +#define LOOKS_LIKE_CLOSURE_PTR(p) \ + ( LOOKS_LIKE_PTR(p) && \ + LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) /* * The layout of the StgFunInfoExtra part of an info table changes ===================================== rts/include/MachDeps.h ===================================== @@ -107,6 +107,17 @@ #endif #endif +// This is the bit-pattern used by the RTS to clear freed memory +// when +RTS -DZ is in use. The LOOKS_LIKE_*_PTR utilities use this +// macro to catch clearly invalid pointers +#if !defined(INVALID_GHC_POINTER) +#if SIZEOF_HSWORD == 4 +#define INVALID_GHC_POINTER 0xaaaaaaaa +#else +#define INVALID_GHC_POINTER 0xaaaaaaaaaaaaaaaa +#endif +#endif + #if !defined(TAG_BITS) #if SIZEOF_HSWORD == 4 #define TAG_BITS 2 ===================================== rts/include/rts/storage/ClosureMacros.h ===================================== @@ -270,6 +270,12 @@ EXTERN_INLINE StgClosure *TAG_CLOSURE(StgWord tag,StgClosure * p) make sense... -------------------------------------------------------------------------- */ +EXTERN_INLINE bool LOOKS_LIKE_PTR (const void* p); +EXTERN_INLINE bool LOOKS_LIKE_PTR (const void* p) +{ + return p && (p != (const void*) INVALID_GHC_POINTER); +} + EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p); EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p) { @@ -280,12 +286,13 @@ EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p) EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR (StgWord p); EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR (StgWord p) { - return p && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p)); + return LOOKS_LIKE_PTR((const void*) p) && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p)); } EXTERN_INLINE bool LOOKS_LIKE_CLOSURE_PTR (const void *p); EXTERN_INLINE bool LOOKS_LIKE_CLOSURE_PTR (const void *p) { + if (!LOOKS_LIKE_PTR(p)) return false; const StgInfoTable *info = RELAXED_LOAD(&UNTAG_CONST_CLOSURE((const StgClosure *) (p))->header.info); return LOOKS_LIKE_INFO_PTR((StgWord) info); } ===================================== rts/sm/Evac.c ===================================== @@ -1030,8 +1030,10 @@ loop: return; case TSO: + { copy(p,info,q,sizeofW(StgTSO),gen_no); return; + } case STACK: { ===================================== rts/sm/Sanity.c ===================================== @@ -737,6 +737,27 @@ checkSTACK (StgStack *stack) checkStackChunk(sp, stack_end); } +/* + * Note [Avoid dangling global_link pointers] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * TSOs are a bit odd in that they have a global_link pointer field + * which is not scavenged by the GC. This field is used to track the + * generations[_].[old_]threads lists and is ultimately updated by + * MarkWeak.c:tidyThreadList. + + * Typically the fact that this field is not scavenged is fine as all reachable + * TSOs on the heap are guaranteed to be on some generation's thread list and + * therefore will be scavenged by tidyThreadList. However, the sanity checker + * poses a bit of a challenge here as it walks heap blocks directly and + * therefore may encounter TSOs which aren't reachable via the heap. + * For this reason, checkTSO does not check global_link. Instead, we only do + * so in checkGlobalTSOList, which by definition will only look at + * threads which are reachable via a thread list (and therefore must have won + * the forwarding-pointer race). + * + * See #19146. + */ + void checkTSO(StgTSO *tso) { @@ -761,9 +782,11 @@ checkTSO(StgTSO *tso) ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->stackobj)); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && - (tso->global_link == END_TSO_QUEUE || - get_itbl((StgClosure*)tso->global_link)->type == TSO)); + + // This assertion is sadly not viable. See Note [Sanity-checking global_link]. + //ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && + // (tso->global_link == END_TSO_QUEUE || + // get_itbl((StgClosure*)tso->global_link)->type == TSO)); if (tso->label) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->label)); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d2bcf3472a825bafc11e90b5e5f8b8d40cd6bc67...593058d280912576c595a0d6e3619c7f90cbaf0a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d2bcf3472a825bafc11e90b5e5f8b8d40cd6bc67...593058d280912576c595a0d6e3619c7f90cbaf0a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 19:55:14 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 02 May 2023 15:55:14 -0400 Subject: [Git][ghc/ghc][wip/T19146] 7 commits: rts: Clear block_info when unblocking Message-ID: <64516aa2db4e7_3c911551f2c1347c@gitlab.mail> Ben Gamari pushed to branch wip/T19146 at Glasgow Haskell Compiler / GHC Commits: d1540380 by Ben Gamari at 2023-05-02T15:50:41-04:00 rts: Clear block_info when unblocking Otherwise we may end up with dangling pointers which may complicate debugging. - - - - - 251f4a5a by Ben Gamari at 2023-05-02T15:52:07-04:00 rts: Weak pointer cleanups Various stylistic cleanups. No functional changes. - - - - - 4102dbc3 by Ben Gamari at 2023-05-02T15:52:37-04:00 rts: Don't force debug output to stderr Previously `+RTS -Dw -l` would emit debug output to the eventlog while `+RTS -l -Dw` would emit it to stderr. This was because the parser for `-D` would unconditionally override the debug output target. Now we instead only do so if no it is currently `TRACE_NONE`. - - - - - c5a93c73 by Ben Gamari at 2023-05-02T15:53:50-04:00 rts: Forcibly flush eventlog on barf Previously we would attempt to flush via `endEventLogging` which can easily deadlock, e.g., if `barf` fails during GC. Using `flushEventLog` directly may result in slightly less consistent eventlog output (since we don't take all capabilities before flushing) but avoids deadlocking. - - - - - 71fb0a37 by Ben Gamari at 2023-05-02T15:53:53-04:00 rts: Assert that pointers aren't cleared This turns many segmentation faults into much easier-to-debug assertion failures by ensuring that LOOKS_LIKE_*_PTR checks recognize bit-patterns produced by `+RTS -DZ` clearing as invalid pointers. This is a bit ad-hoc but this is the debug runtime. - - - - - 0aeb9d4f by Ben Gamari at 2023-05-02T15:54:40-04:00 rts: Don't sanity-check StgTSO.global_link See Note [Avoid dangling global_link pointers]. Fixes #19146. - - - - - 280bace4 by Ben Gamari at 2023-05-02T15:54:59-04:00 rts: Introduce printGlobalThreads - - - - - 13 changed files: - rts/RaiseAsync.c - rts/RtsFlags.c - rts/RtsMessages.c - rts/Schedule.c - rts/Threads.c - rts/Threads.h - rts/include/Cmm.h - rts/include/MachDeps.h - rts/include/rts/storage/ClosureMacros.h - rts/posix/Select.c - rts/sm/MarkWeak.c - rts/sm/Sanity.c - rts/win32/AsyncMIO.c Changes: ===================================== rts/RaiseAsync.c ===================================== @@ -729,6 +729,7 @@ removeFromQueues(Capability *cap, StgTSO *tso) done: tso->why_blocked = NotBlocked; + tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; appendToRunQueue(cap, tso); } @@ -1092,6 +1093,7 @@ done: // wake it up if (tso->why_blocked != NotBlocked) { tso->why_blocked = NotBlocked; + tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; appendToRunQueue(cap,tso); } ===================================== rts/RtsFlags.c ===================================== @@ -2201,13 +2201,14 @@ static void read_debug_flags(const char* arg) } // -Dx also turns on -v. Use -l to direct trace // events to the .eventlog file instead. - RtsFlags.TraceFlags.tracing = TRACE_STDERR; - - // sanity implies zero_on_gc - if(RtsFlags.DebugFlags.sanity){ - RtsFlags.DebugFlags.zero_on_gc = true; - } + if (RtsFlags.TraceFlags.tracing == TRACE_NONE) { + RtsFlags.TraceFlags.tracing = TRACE_STDERR; + } + // sanity implies zero_on_gc + if(RtsFlags.DebugFlags.sanity){ + RtsFlags.DebugFlags.zero_on_gc = true; + } } #endif ===================================== rts/RtsMessages.c ===================================== @@ -186,7 +186,12 @@ rtsFatalInternalErrorFn(const char *s, va_list ap) #endif #if defined(TRACING) - if (RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG) endEventLogging(); + if (RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG) { + // Use flushAllCapsEventsBufs rather than endEventLogging here since + // the latter insists on acquiring all capabilities to flush the eventlog; + // this would deadlock if we barfed during a GC. + flushAllCapsEventsBufs(); + } #endif abort(); ===================================== rts/Schedule.c ===================================== @@ -2565,7 +2565,8 @@ resumeThread (void *task_) traceEventRunThread(cap, tso); /* Reset blocking status */ - tso->why_blocked = NotBlocked; + tso->why_blocked = NotBlocked; + tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; if ((tso->flags & TSO_BLOCKEX) == 0) { // avoid locking the TSO if we don't have to ===================================== rts/Threads.c ===================================== @@ -334,6 +334,7 @@ unblock: // just run the thread now, if the BH is not really available, // we'll block again. tso->why_blocked = NotBlocked; + tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; appendToRunQueue(cap,tso); // We used to set the context switch flag here, which would @@ -1007,6 +1008,20 @@ printAllThreads(void) } } +void +printGlobalThreads(void) +{ + for (uint32_t g = 0; g < RtsFlags.GcFlags.generations; g++) { + debugBelch("\ngen %d\n", g); + for (StgTSO *t = generations[g].threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu)\n", t, t->id); + } + for (StgTSO *t = generations[g].old_threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu) (old)\n", t, t->id); + } + } +} + // useful from gdb void printThreadQueue(StgTSO *t) ===================================== rts/Threads.h ===================================== @@ -46,6 +46,7 @@ bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value); void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); void printAllThreads (void); +void printGlobalThreads(void); void printThreadQueue (StgTSO *t); #endif ===================================== rts/include/Cmm.h ===================================== @@ -605,16 +605,20 @@ #define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK) #define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT) +#define LOOKS_LIKE_PTR(p) ((p) != NULL && (p) != INVALID_GHC_POINTER) + /* Debugging macros */ #define LOOKS_LIKE_INFO_PTR(p) \ - ((p) != NULL && \ + (LOOKS_LIKE_PTR(p) && \ LOOKS_LIKE_INFO_PTR_NOT_NULL(p)) #define LOOKS_LIKE_INFO_PTR_NOT_NULL(p) \ ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) && \ (TO_W_(%INFO_TYPE(%STD_INFO(p))) < N_CLOSURE_TYPES)) -#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) +#define LOOKS_LIKE_CLOSURE_PTR(p) \ + ( LOOKS_LIKE_PTR(p) && \ + LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) /* * The layout of the StgFunInfoExtra part of an info table changes ===================================== rts/include/MachDeps.h ===================================== @@ -107,6 +107,17 @@ #endif #endif +// This is the bit-pattern used by the RTS to clear freed memory +// when +RTS -DZ is in use. The LOOKS_LIKE_*_PTR utilities use this +// macro to catch clearly invalid pointers +#if !defined(INVALID_GHC_POINTER) +#if SIZEOF_HSWORD == 4 +#define INVALID_GHC_POINTER 0xaaaaaaaa +#else +#define INVALID_GHC_POINTER 0xaaaaaaaaaaaaaaaa +#endif +#endif + #if !defined(TAG_BITS) #if SIZEOF_HSWORD == 4 #define TAG_BITS 2 ===================================== rts/include/rts/storage/ClosureMacros.h ===================================== @@ -270,6 +270,12 @@ EXTERN_INLINE StgClosure *TAG_CLOSURE(StgWord tag,StgClosure * p) make sense... -------------------------------------------------------------------------- */ +EXTERN_INLINE bool LOOKS_LIKE_PTR (const void* p); +EXTERN_INLINE bool LOOKS_LIKE_PTR (const void* p) +{ + return p && (p != (const void*) INVALID_GHC_POINTER); +} + EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p); EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p) { @@ -280,12 +286,13 @@ EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p) EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR (StgWord p); EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR (StgWord p) { - return p && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p)); + return LOOKS_LIKE_PTR((const void*) p) && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p)); } EXTERN_INLINE bool LOOKS_LIKE_CLOSURE_PTR (const void *p); EXTERN_INLINE bool LOOKS_LIKE_CLOSURE_PTR (const void *p) { + if (!LOOKS_LIKE_PTR(p)) return false; const StgInfoTable *info = RELAXED_LOAD(&UNTAG_CONST_CLOSURE((const StgClosure *) (p))->header.info); return LOOKS_LIKE_INFO_PTR((StgWord) info); } ===================================== rts/posix/Select.c ===================================== @@ -106,6 +106,7 @@ static bool wakeUpSleepingThreads (Capability *cap, LowResTime now) } iomgr->sleeping_queue = tso->_link; tso->why_blocked = NotBlocked; + tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; tso->_link = END_TSO_QUEUE; IF_DEBUG(scheduler, debugBelch("Waking up sleeping thread %" FMT_StgThreadID "\n", tso->id)); @@ -437,6 +438,7 @@ awaitEvent(Capability *cap, bool wait) debugBelch("Waking up blocked thread %" FMT_StgThreadID "\n", tso->id)); tso->why_blocked = NotBlocked; + tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; tso->_link = END_TSO_QUEUE; pushOnRunQueue(cap,tso); break; ===================================== rts/sm/MarkWeak.c ===================================== @@ -251,7 +251,7 @@ static void collectDeadWeakPtrs (generation *gen, StgWeak **dead_weak_ptr_list) */ static bool resurrectUnreachableThreads (generation *gen, StgTSO **resurrected_threads) { - StgTSO *t, *tmp, *next; + StgTSO *t, *next; bool flag = false; for (t = gen->old_threads; t != END_TSO_QUEUE; t = next) { @@ -272,12 +272,14 @@ static bool resurrectUnreachableThreads (generation *gen, StgTSO **resurrected_t t->global_link = END_TSO_QUEUE; continue; default: - tmp = t; + { + StgTSO *tmp = t; evacuate((StgClosure **)&tmp); tmp->global_link = *resurrected_threads; *resurrected_threads = tmp; flag = true; } + } } gen->old_threads = END_TSO_QUEUE; @@ -387,18 +389,21 @@ static bool tidyWeakList(generation *gen) } /* - * Walk over the `old_threads` list of the given generation and move any - * reachable threads onto the `threads` list. + * Walk over the given generation's thread list and promote TSOs which are + * reachable via the heap. This will move the TSO from gen->old_threads to + * new_gen->threads. + * + * This has the side-effect of updating the global thread list to account for + * indirections introduced by evacuation. */ static void tidyThreadList (generation *gen) { - StgTSO *t, *tmp, *next, **prev; + StgTSO *next; + StgTSO **prev = &gen->old_threads; - prev = &gen->old_threads; - - for (t = gen->old_threads; t != END_TSO_QUEUE; t = next) { + for (StgTSO *t = gen->old_threads; t != END_TSO_QUEUE; t = next) { - tmp = (StgTSO *)isAlive((StgClosure *)t); + StgTSO *tmp = (StgTSO *)isAlive((StgClosure *)t); if (tmp != NULL) { t = tmp; @@ -426,10 +431,9 @@ static void tidyThreadList (generation *gen) *prev = next; // move this thread onto the correct threads list. - generation *new_gen; - new_gen = Bdescr((P_)t)->gen; + generation *new_gen = Bdescr((P_)t)->gen; t->global_link = new_gen->threads; - new_gen->threads = t; + new_gen->threads = t; } } } ===================================== rts/sm/Sanity.c ===================================== @@ -737,14 +737,34 @@ checkSTACK (StgStack *stack) checkStackChunk(sp, stack_end); } +/* + * Note [Avoid dangling global_link pointers] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * TSOs are a bit odd in that they have a global_link pointer field + * which is not scavenged by the GC. This field is used to track the + * generations[_].[old_]threads lists and is ultimately updated by + * MarkWeak.c:tidyThreadList. + + * Typically the fact that this field is not scavenged is fine as all reachable + * TSOs on the heap are guaranteed to be on some generation's thread list and + * therefore will be scavenged by tidyThreadList. However, the sanity checker + * poses a bit of a challenge here as it walks heap blocks directly and + * therefore may encounter TSOs which aren't reachable via the heap. + * For this reason, checkTSO does not check global_link. Instead, we only do + * so in checkGlobalTSOList, which by definition will only look at + * threads which are reachable via a thread list (and therefore must have won + * the forwarding-pointer race). + * + * See #19146. + */ + void checkTSO(StgTSO *tso) { - StgTSO *next = tso->_link; const StgInfoTable *info = (const StgInfoTable*) tso->_link->header.info; load_load_barrier(); - ASSERT(next == END_TSO_QUEUE || + ASSERT(tso->_link == END_TSO_QUEUE || info == &stg_MVAR_TSO_QUEUE_info || info == &stg_TSO_info || info == &stg_WHITEHOLE_info); // used to happen due to STM doing @@ -762,9 +782,11 @@ checkTSO(StgTSO *tso) ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->stackobj)); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && - (tso->global_link == END_TSO_QUEUE || - get_itbl((StgClosure*)tso->global_link)->type == TSO)); + + // This assertion is sadly not viable. See Note [Sanity-checking global_link]. + //ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && + // (tso->global_link == END_TSO_QUEUE || + // get_itbl((StgClosure*)tso->global_link)->type == TSO)); if (tso->label) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->label)); ===================================== rts/win32/AsyncMIO.c ===================================== @@ -321,6 +321,7 @@ start: // Terminates the run queue + this inner for-loop. tso->_link = END_TSO_QUEUE; tso->why_blocked = NotBlocked; + tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; // save the StgAsyncIOResult in the // stg_block_async_info stack frame, because // the block_info field will be overwritten by View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/593058d280912576c595a0d6e3619c7f90cbaf0a...280bace467a531d00be6e5d448c528b09b0dbc5a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/593058d280912576c595a0d6e3619c7f90cbaf0a...280bace467a531d00be6e5d448c528b09b0dbc5a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 21:26:10 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Tue, 02 May 2023 17:26:10 -0400 Subject: [Git][ghc/ghc][wip/T23307] Wibbles Message-ID: <64517ff270320_3c911551f2c14338f@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23307 at Glasgow Haskell Compiler / GHC Commits: 76cb9a77 by Simon Peyton Jones at 2023-05-02T22:27:20+01:00 Wibbles * Improve Wrinkle W4 * Delete redundant guard - - - - - 1 changed file: - compiler/GHC/Types/Id/Make.hs Changes: ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1053,7 +1053,6 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty arg_ty' = case mb_co of { Just redn -> scaledSet arg_ty (reductionReducedType redn) ; Nothing -> arg_ty } - , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty') , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty' = if bang_opt_unbox_disable bang_opts then HsStrict True -- Not unpacking because of -O0 @@ -1389,11 +1388,12 @@ shouldUnpackTy bang_opts prag fam_envs ty | (_:_:_) <- data_cons -> False -- Don't unpack sum types automatically, but they can -- be unpacked with an explicit source UNPACK. - | otherwise + | otherwise -- Wrinkle (W4) of Note [Recursive unboxing] -> bang_opt_unbox_strict bang_opts || (bang_opt_unbox_small bang_opts && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] - where (rep_tys, _) = dataConArgUnpack ty + where + (rep_tys, _) = dataConArgUnpack ty -- Given a type already assumed to have been normalized by topNormaliseType, -- unpackable_type_datacons ty = Just datacons @@ -1496,12 +1496,25 @@ Wrinkles: field of `Unconsed`: we never unpack a sum type without an explicit pragma (see should_unpack). -(W4) We behave conservatively when there is no UNPACK pragma - data T = MkS !T Int - with -funbox-strict-fields or -funbox-small-strict-fields - we behave as if there was an UNPACK pragma there. "Conservative" - in the sense that we recurse more often, which may stop us unboxing - because we find a loop at the toot. +(W4) Consider + data T = MkT !Wombat + data Wombat = MkW {-# UNPACK #-} !S Int + data S = MkS {-# NOUNPACK #-} !Wombat Int + Suppose we are deciding whether to unpack the first field of MkT, by + calling (shouldUnpackTy Wombat). Then we'll try to unpack the !S field + of MkW, and be stopped by the {-# NOUNPACK #-}, and all is fine; we can + unpack MkT. + + If that NOUNPACK had been a UNPACK, though, we'd get a loop, and would + decide not to unpack the Wombat field of MkT. + + But what if there was no pragma in `data S`? Then we /still/ decide not + to unpack the Wombat field of MkT (at least when auto-unpacking is on), + because we don't know for sure which decision will be taken for the + Wombat field of MkS. + + TL;DR when there is no pragma, behave as if there was a UNPACK, at least + when auto-unpacking is on. See `should_unpack` in `shouldUnpackTy`. ************************************************************************ * * View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76cb9a77b1088e3e4141174ea7d2cb18200b4ac1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76cb9a77b1088e3e4141174ea7d2cb18200b4ac1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 21:35:41 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Tue, 02 May 2023 17:35:41 -0400 Subject: [Git][ghc/ghc][wip/T23083] 2 commits: CorePrep: Eliminate EmptyCase and unsafeEqualityProof in CoreToStg instead Message-ID: <6451822d60e62_3c911551e141518aa@gitlab.mail> Sebastian Graf pushed to branch wip/T23083 at Glasgow Haskell Compiler / GHC Commits: f6c98b85 by Sebastian Graf at 2023-05-02T23:35:21+02:00 CorePrep: Eliminate EmptyCase and unsafeEqualityProof in CoreToStg instead We eliminate EmptyCase by way of `coreToStg (Case e _ _ []) = coreToStg e` now. The main reason is that it plays far better in conjunction with eta expansion (as we aim to do for arguments in CorePrep, #23083), because we can discard any arguments, `(case e of {}) eta == case e of {}`, whereas in `(e |> co) eta` it's impossible to discard the argument. We do also give the same treatment to unsafeCoerce proofs and treat them as trivial iff their RHS is trivial. It is also both much simpler to describe than the previous mechanism of emitting an unsafe coercion and simpler to implement, removing quite a bit of commentary and `CorePrepProv`. - - - - - fd286b50 by Sebastian Graf at 2023-05-02T23:35:21+02:00 CorePrep: Eta expand arguments (#23083) Previously, we'd only eta expand let bindings and lambdas, now we'll also eta expand arguments such as in T23083: ```hs g f h = f (h `seq` (h $)) ``` Unless `-fpedantic-bottoms` is set, we'll now transform to ```hs g f h = f (\eta -> h eta) ``` in CorePrep. See the new `Note [Eta expansion of arguments in CorePrep]` for the details. We only do this optimisation with -O2 because we saw 2-3% ghc/alloc regressions in T4801 and T5321FD. Fixes #23083. - - - - - 30 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCo/Tidy.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/CoreToStg/Prep.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Utils/Trace.hs - docs/users_guide/using-optimisation.rst - libraries/base/Unsafe/Coerce.hs - + testsuite/tests/simplCore/should_compile/T23083.hs - + testsuite/tests/simplCore/should_compile/T23083.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -717,9 +717,12 @@ this exhaustive list can be empty! its scrutinee is (see GHC.Core.Utils.exprIsTrivial). This is actually important; see Note [Empty case is trivial] in GHC.Core.Utils -* An empty case is replaced by its scrutinee during the CoreToStg - conversion; remember STG is un-typed, so there is no need for - the empty case to do the type conversion. +* We lower empty cases in GHC.CoreToStg to an eval on the scrutinee. + +Historical Note: We used to lower EmptyCase in CorePrep by way of an +unsafeCoercion on the scrutinee, but that yielded panics in CodeGen when +we were beginning to eta expand in arguments, plus required to mess with +heterogenously-kinded coercions. It's simpler to stick to it just a bit longer. Note [Join points] ~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -1390,7 +1390,6 @@ setNominalRole_maybe r co | case prov of PhantomProv _ -> False -- should always be phantom ProofIrrelProv _ -> True -- it's always safe PluginProv _ -> False -- who knows? This choice is conservative. - CorePrepProv _ -> True = Just $ UnivCo prov Nominal co1 co2 setNominalRole_maybe_helper _ = Nothing @@ -1516,7 +1515,6 @@ promoteCoercion co = case co of UnivCo (PhantomProv kco) _ _ _ -> kco UnivCo (ProofIrrelProv kco) _ _ _ -> kco UnivCo (PluginProv _) _ _ _ -> mkKindCo co - UnivCo (CorePrepProv _) _ _ _ -> mkKindCo co SymCo g -> mkSymCo (promoteCoercion g) @@ -2339,7 +2337,6 @@ seqProv :: UnivCoProvenance -> () seqProv (PhantomProv co) = seqCo co seqProv (ProofIrrelProv co) = seqCo co seqProv (PluginProv _) = () -seqProv (CorePrepProv _) = () seqCos :: [Coercion] -> () seqCos [] = () ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -622,7 +622,6 @@ opt_univ env sym prov role oty1 oty2 #endif ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco PluginProv _ -> prov - CorePrepProv _ -> prov ------------- opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -410,7 +410,6 @@ orphNamesOfProv :: UnivCoProvenance -> NameSet orphNamesOfProv (PhantomProv co) = orphNamesOfCo co orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co orphNamesOfProv (PluginProv _) = emptyNameSet -orphNamesOfProv (CorePrepProv _) = emptyNameSet orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo @@ -798,4 +797,3 @@ freeVars = go go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) - ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -2301,9 +2301,6 @@ lintCoercion co@(UnivCo prov r ty1 ty2) -- see #9122 for discussion of these checks checkTypes t1 t2 - | allow_ill_kinded_univ_co prov - = return () -- Skip kind checks - | otherwise = do { checkWarnL fixed_rep_1 (report "left-hand type does not have a fixed runtime representation") ; checkWarnL fixed_rep_2 @@ -2321,13 +2318,6 @@ lintCoercion co@(UnivCo prov r ty1 ty2) reps1 = typePrimRep t1 reps2 = typePrimRep t2 - -- CorePrep deliberately makes ill-kinded casts - -- e.g (case error @Int "blah" of {}) :: Int# - -- ==> (error @Int "blah") |> Unsafe Int Int# - -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep - allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind - allow_ill_kinded_univ_co _ = False - validateCoercion :: PrimRep -> PrimRep -> LintM () validateCoercion rep1 rep2 = do { platform <- getPlatform @@ -2357,8 +2347,7 @@ lintCoercion co@(UnivCo prov r ty1 ty2) ; check_kinds kco k1 k2 ; return (ProofIrrelProv kco') } - lint_prov _ _ prov@(PluginProv _) = return prov - lint_prov _ _ prov@(CorePrepProv _) = return prov + lint_prov _ _ prov@(PluginProv _) = return prov check_kinds kco k1 k2 = do { let Pair k1' k2' = coercionKind kco ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -661,7 +661,6 @@ tyCoFVsOfProv :: UnivCoProvenance -> FV tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfProv (CorePrepProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc @@ -731,8 +730,7 @@ almost_devoid_co_var_of_prov (PhantomProv co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_prov (ProofIrrelProv co) cv = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (PluginProv _) _ = True -almost_devoid_co_var_of_prov (CorePrepProv _) _ = True +almost_devoid_co_var_of_prov (PluginProv _) _ = True almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True @@ -1131,9 +1129,6 @@ tyConsOfType ty go_prov (PhantomProv co) = go_co co go_prov (ProofIrrelProv co) = go_co co go_prov (PluginProv _) = emptyUniqSet - go_prov (CorePrepProv _) = emptyUniqSet - -- this last case can happen from the tyConsOfType used from - -- checkTauTvUpdate go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos @@ -1345,5 +1340,3 @@ occCheckExpand vs_to_avoid ty go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co go_prov _ p@(PluginProv _) = return p - go_prov _ p@(CorePrepProv _) = return p - ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1437,17 +1437,12 @@ data UnivCoProvenance | PluginProv String -- ^ From a plugin, which asserts that this coercion -- is sound. The string is for the use of the plugin. - | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep - Bool -- True <=> the UnivCo must be homogeneously kinded - -- False <=> allow hetero-kinded, e.g. Int ~ Int# - deriving Data.Data instance Outputable UnivCoProvenance where ppr (PhantomProv _) = text "(phantom)" ppr (ProofIrrelProv _) = text "(proof irrel.)" ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) - ppr (CorePrepProv _) = text "(CorePrep)" -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole @@ -1760,7 +1755,6 @@ foldTyCo (TyCoFolder { tcf_view = view go_prov env (PhantomProv co) = go_co env co go_prov env (ProofIrrelProv co) = go_co env co go_prov _ (PluginProv _) = mempty - go_prov _ (CorePrepProv _) = mempty -- | A view function that looks through nothing. noView :: Type -> Maybe Type @@ -1826,7 +1820,6 @@ provSize :: UnivCoProvenance -> Int provSize (PhantomProv co) = 1 + coercionSize co provSize (ProofIrrelProv co) = 1 + coercionSize co provSize (PluginProv _) = 1 -provSize (CorePrepProv _) = 1 {- ************************************************************************ ===================================== compiler/GHC/Core/TyCo/Subst.hs ===================================== @@ -912,7 +912,6 @@ subst_co subst co go_prov (PhantomProv kco) = PhantomProv (go kco) go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) go_prov p@(PluginProv _) = p - go_prov p@(CorePrepProv _) = p -- See Note [Substituting in a coercion hole] go_hole h@(CoercionHole { ch_co_var = cv }) ===================================== compiler/GHC/Core/TyCo/Tidy.hs ===================================== @@ -252,7 +252,6 @@ tidyCo env@(_, subst) co go_prov (PhantomProv co) = PhantomProv $! go co go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co go_prov p@(PluginProv _) = p - go_prov p@(CorePrepProv _) = p tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env) ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -580,7 +580,6 @@ expandTypeSynonyms ty go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) go_prov _ p@(PluginProv _) = p - go_prov _ p@(CorePrepProv _) = p -- the "False" and "const" are to accommodate the type of -- substForAllCoBndrUsing, which is general enough to @@ -998,7 +997,6 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar go_prov env (PhantomProv co) = PhantomProv <$> go_co env co go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co go_prov _ p@(PluginProv _) = return p - go_prov _ p@(CorePrepProv _) = return p {- ********************************************************************* ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -249,8 +249,11 @@ inlineBoringOk e , exprIsTrivial a = go (credit-1) f go credit (Tick _ e) = go credit e -- dubious go credit (Cast e _) = go credit e - go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce] - | isUnsafeEqualityProof scrut = go credit rhs + go credit (Case e b _ alts) + | null alts + = go credit e -- EmptyCase is like e + | Just rhs <- isUnsafeEqualityCase e b alts + = go credit rhs -- See Note [Inline unsafeCoerce] go _ (Var {}) = boringCxtOk go _ (Lit l) = litIsTrivial l && boringCxtOk go _ _ = boringCxtNotOk @@ -304,7 +307,7 @@ calcUnfoldingGuidance opts is_top_bottoming expr We really want to inline unsafeCoerce, even when applied to boring arguments. It doesn't look as if its RHS is smaller than the call unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x -but that case is discarded -- see Note [Implementing unsafeCoerce] +but that case is discarded in CoreToStg -- see Note [Implementing unsafeCoerce] in base:Unsafe.Coerce. Moreover, if we /don't/ inline it, we may be left with @@ -312,7 +315,9 @@ Moreover, if we /don't/ inline it, we may be left with which will build a thunk -- bad, bad, bad. Conclusion: we really want inlineBoringOk to be True of the RHS of -unsafeCoerce. This is (U4) in Note [Implementing unsafeCoerce]. +unsafeCoerce. And it really is, because we regard + case unsafeEqualityProof @a @b of UnsafeRefl -> rhs +as trivial iff rhs is. This is (U4) in Note [Implementing unsafeCoerce]. Note [Computing the size of an expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -59,7 +59,7 @@ module GHC.Core.Utils ( mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId, -- * unsafeEqualityProof - isUnsafeEqualityProof, + isUnsafeEqualityCase, -- * Dumping stuff dumpIdInfoOfProgram @@ -79,7 +79,7 @@ import GHC.Core.Reduction import GHC.Core.TyCon import GHC.Core.Multiplicity -import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey ) +import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey ) import GHC.Builtin.PrimOps import GHC.Types.Var @@ -1072,7 +1072,11 @@ trivial_expr_fold k_id k_lit k_triv k_not_triv = go go (Lam b e) | not (isRuntimeVar b) = go e go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial] go (Cast e _) = go e - go (Case e _ _ []) = go e -- See Note [Empty case is trivial] + go (Case e b _ as) + | null as + = go e -- See Note [Empty case is trivial] + | Just rhs <- isUnsafeEqualityCase e b as + = go rhs -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce go _ = k_not_triv exprIsTrivial :: CoreExpr -> Bool @@ -2707,11 +2711,22 @@ wantCbvForId cbv_for_strict v * * ********************************************************************* -} -isUnsafeEqualityProof :: CoreExpr -> Bool +isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr -- See (U3) and (U4) in -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce -isUnsafeEqualityProof e - | Var v `App` Type _ `App` Type _ `App` Type _ <- e - = v `hasKey` unsafeEqualityProofIdKey - | otherwise - = False +isUnsafeEqualityCase scrut bndr [Alt ac _ rhs] + | DataAlt dc <- ac + , not (dc `hasKey` unsafeReflDataConKey) + = Nothing -- fast path for DataAlt + + | isDeadBinder bndr + -- We can only discard the case if the case-binder is dead + -- It usually is, but see #18227 + , Var v `App` _ `App` _ `App` _ <- scrut + , v `hasKey` unsafeEqualityProofIdKey + -- Check that the scrutinee really is unsafeEqualityProof + -- and not, say, error + = Just rhs + +isUnsafeEqualityCase _ _ _ + = Nothing ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -321,7 +321,6 @@ toIfaceCoercionX fr co go_prov (PhantomProv co) = IfacePhantomProv (go co) go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) go_prov (PluginProv str) = IfacePluginProv str - go_prov (CorePrepProv b) = IfaceCorePrepProv b toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -19,8 +19,7 @@ module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where import GHC.Prelude import GHC.Core -import GHC.Core.Utils ( exprType, findDefault, isJoinBind - , exprIsTickedString_maybe ) +import GHC.Core.Utils import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core.Type import GHC.Core.TyCon @@ -49,7 +48,7 @@ import GHC.Unit.Module import GHC.Data.FastString import GHC.Platform ( Platform ) import GHC.Platform.Ways -import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId ) +import GHC.Builtin.PrimOps import GHC.Utils.Outputable import GHC.Utils.Monad @@ -430,30 +429,23 @@ coreToStgExpr (Cast expr _) = coreToStgExpr expr -- Cases require a little more real work. - -{- -coreToStgExpr (Case scrut _ _ []) +coreToStgExpr (Case scrut bndr _ alts) + | null alts + -- See Note [Empty case alternatives] in GHC.Core If the case + -- alternatives are empty, the scrutinee must diverge or raise an + -- exception, so we can just dive into it. + -- + -- Of course this may seg-fault if the scrutinee *does* return. A + -- belt-and-braces approach would be to move this case into the + -- code generator, and put a return point anyway that calls a + -- runtime system error function. = coreToStgExpr scrut - -- See Note [Empty case alternatives] in GHC.Core If the case - -- alternatives are empty, the scrutinee must diverge or raise an - -- exception, so we can just dive into it. - -- - -- Of course this may seg-fault if the scrutinee *does* return. A - -- belt-and-braces approach would be to move this case into the - -- code generator, and put a return point anyway that calls a - -- runtime system error function. - -coreToStgExpr e0@(Case scrut bndr _ [alt]) = do - | isUnsafeEqualityProof scrut - , isDeadBinder bndr -- We can only discard the case if the case-binder is dead - -- It usually is, but see #18227 - , (_,_,rhs) <- alt + + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce = coreToStgExpr rhs - -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce --} --- The normal case for case-expressions -coreToStgExpr (Case scrut bndr _ alts) + | otherwise = do { scrut2 <- coreToStgExpr scrut ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts) ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) } @@ -574,6 +566,15 @@ coreToStgApp f args ticks = do -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- +getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg +-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg. +-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or +-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene. +-- Good thing we can just call `trivial_expr_fold` here. +getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg panic panic e + where + panic = pprPanic "getStgArgFromTrivialArg" (ppr e) + coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) coreToStgArgs [] = return ([], []) @@ -586,42 +587,29 @@ coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion token = do { (args', ts) <- coreToStgArgs args ; return (StgVarArg coercionTokenId : args', ts) } -coreToStgArgs (Tick t e : args) - = assert (not (tickishIsCode t)) $ - do { (args', ts) <- coreToStgArgs (e : args) - ; let !t' = coreToStgTick (exprType e) t - ; return (args', t':ts) } - coreToStgArgs (arg : args) = do -- Non-type argument (stg_args, ticks) <- coreToStgArgs args - arg' <- coreToStgExpr arg - let - (aticks, arg'') = stripStgTicksTop tickishFloatable arg' - stg_arg = case arg'' of - StgApp v [] -> StgVarArg v - StgConApp con _ [] _ -> StgVarArg (dataConWorkId con) - StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op) - StgLit lit -> StgLitArg lit - _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'') - - -- WARNING: what if we have an argument like (v `cast` co) - -- where 'co' changes the representation type? - -- (This really only happens if co is unsafe.) - -- Then all the getArgAmode stuff in CgBindery will set the - -- cg_rep of the CgIdInfo based on the type of v, rather - -- than the type of 'co'. - -- This matters particularly when the function is a primop - -- or foreign call. - -- Wanted: a better solution than this hacky warning - + -- We know that `arg` must be trivial, but it may contain Ticks. + -- Example from test case `decodeMyStack`: + -- $ @... ((src Data.Tuple.snd) @Int @[..]) + -- Note that unfortunately the Tick is not at the top. + -- So we'll traverse the expression twice: + -- * Once with `stripTicksT` (which collects *all* ticks from the expression) + -- * and another time with `getStgArgFromTrivialArg`. + -- Since the argument is trivial, the only place the Tick can occur is + -- somehow wrapping a variable (give or take type args, as above). platform <- getPlatform - let - arg_rep = typePrimRep (exprType arg) - stg_arg_rep = typePrimRep (stgArgType stg_arg) + let arg_ty = exprType arg + ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg) + arg' = getStgArgFromTrivialArg arg + arg_rep = typePrimRep arg_ty + stg_arg_rep = typePrimRep (stgArgType arg') bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) - warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $ - return (stg_arg : stg_args, ticks ++ aticks) + massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg) + warnPprTraceM bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) + + return (arg' : stg_args, ticks' ++ ticks) coreToStgTick :: Type -- type of the ticked expression -> CoreTickish @@ -959,6 +947,9 @@ myCollectBinders expr -- | If the argument expression is (potential chain of) 'App', return the head -- of the app chain, and collect ticks/args along the chain. +-- INVARIANT: If the app head is trivial, return the atomic Var/Lit that was +-- wrapped in casts, empty case, ticks, etc. +-- So keep in sync with 'exprIsTrivial'. myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish]) myCollectArgs expr = go expr [] [] @@ -970,8 +961,14 @@ myCollectArgs expr -- See Note [Ticks in applications] go e as (t:ts) -- ticks can appear in type apps go (Cast e _) as ts = go e as ts + go (Case e b _ alts) as ts + | null alts + = assertPpr (null as) (ppr e $$ ppr as $$ ppr expr) $ + go e [] ts -- NB: Empty case discards arguments + | Just rhs <- isUnsafeEqualityCase e b alts + = go rhs as ts -- Discards unsafeCoerce in App heads go (Lam b e) as ts - | isTyVar b = go e as ts -- Note [Collect args] + | isTyVar b = go e (drop 1 as) ts -- Note [Collect args] go e as ts = (e, as, ts) {- Note [Collect args] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -40,12 +40,10 @@ import GHC.Core.Coercion import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal -import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Data.FastString -import GHC.Data.Pair import GHC.Data.Graph.UnVar import GHC.Utils.Error @@ -70,8 +68,7 @@ import GHC.Types.Tickish import GHC.Types.TyThing import GHC.Types.Unique.Supply -import Data.List ( unfoldr ) -import Data.Functor.Identity +import Data.List ( unfoldr, partition ) import Control.Monad {- @@ -142,10 +139,7 @@ The goal of this pass is to prepare for code generation. profiling mode. We have to do this here because we won't have unfoldings after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules]. -12. Eliminate case clutter in favour of unsafe coercions. - See Note [Unsafe coercions] - -13. Eliminate some magic Ids, specifically +12. Eliminate some magic Ids, specifically runRW# (\s. e) ==> e[readWorldId/s] lazy e ==> e (see Note [lazyId magic] in GHC.Types.Id.Make) noinline e ==> e @@ -157,48 +151,6 @@ This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. -Note [Unsafe coercions] -~~~~~~~~~~~~~~~~~~~~~~~ -CorePrep does these two transformations: - -1. Convert empty case to cast with an unsafe coercion - (case e of {}) ===> e |> unsafe-co - See Note [Empty case alternatives] in GHC.Core: if the case - alternatives are empty, the scrutinee must diverge or raise an - exception, so we can just dive into it. - - Of course, if the scrutinee *does* return, we may get a seg-fault. - A belt-and-braces approach would be to persist empty-alternative - cases to code generator, and put a return point anyway that calls a - runtime system error function. - - Notice that eliminating empty case can lead to an ill-kinded coercion - case error @Int "foo" of {} :: Int# - ===> error @Int "foo" |> unsafe-co - where unsafe-co :: Int ~ Int# - But that's fine because the expression diverges anyway. And it's - no different to what happened before. - -2. Eliminate unsafeEqualityProof in favour of an unsafe coercion - case unsafeEqualityProof of UnsafeRefl g -> e - ===> e[unsafe-co/g] - See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce - - Note that this requires us to substitute 'unsafe-co' for 'g', and - that is the main (current) reason for cpe_tyco_env in CorePrepEnv. - Tiresome, but not difficult. - -These transformations get rid of "case clutter", leaving only casts. -We are doing no further significant transformations, so the reasons -for the case forms have disappeared. And it is extremely helpful for -the ANF-ery, CoreToStg, and backends, if trivial expressions really do -look trivial. #19700 was an example. - -In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)), -The boolean 'b' says whether the unsafe coercion is supposed to be -kind-homogeneous (yes for (2), no for (1). This information is used -/only/ by Lint. - Note [CorePrep invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is the syntax of the Core produced by CorePrep: @@ -628,11 +580,14 @@ cpeBind top_lvl env (Rec pairs) bndrs1 rhss ; let (floats_s, rhss1) = unzip stuff - all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) - (concatFloats floats_s) + (strs, floats) = partitionOL isFloatString (concatFloats floats_s) + str_floats = mkFloats strs + all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) floats + + -- use env below, so that we reset cpe_rec_ids ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1), - unitFloat (FloatLet (Rec all_pairs)), + str_floats `appendFloats` unitFloat (FloatLet (Rec all_pairs)), Nothing) } | otherwise -- See Note [Join points and floating] @@ -652,7 +607,8 @@ cpeBind top_lvl env (Rec pairs) -- group into a single giant Rec add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 - add_float b _ = pprPanic "cpeBind" (ppr b) + add_float (FloatString r b) prs2 = (b,r):prs2 + add_float b _ = pprPanic "cpeBind" (ppr b) --------------- cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool @@ -785,10 +741,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- For example -- f (g x) ===> ([v = g x], f v) -cpeRhsE env (Type ty) - = return (emptyFloats, Type (cpSubstTy env ty)) -cpeRhsE env (Coercion co) - = return (emptyFloats, Coercion (cpSubstCo env co)) +cpeRhsE _ (Type ty) + = return (emptyFloats, Type ty) +cpeRhsE _ (Coercion co) + = return (emptyFloats, Coercion co) cpeRhsE env expr@(Lit (LitNumber nt i)) = case cp_convertNumLit (cpe_config env) nt i of Nothing -> return (emptyFloats, expr) @@ -822,7 +778,7 @@ cpeRhsE env (Tick tickish expr) cpeRhsE env (Cast expr co) = do { (floats, expr') <- cpeRhsE env expr - ; return (floats, Cast expr' (cpSubstCo env co)) } + ; return (floats, Cast expr' co) } cpeRhsE env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr @@ -830,36 +786,6 @@ cpeRhsE env expr@(Lam {}) ; body' <- cpeBodyNF env' body ; return (emptyFloats, mkLams bndrs' body') } --- Eliminate empty case --- See Note [Unsafe coercions] -cpeRhsE env (Case scrut _ ty []) - = do { (floats, scrut') <- cpeRhsE env scrut - ; let ty' = cpSubstTy env ty - scrut_ty' = exprType scrut' - co' = mkUnivCo prov Representational scrut_ty' ty' - prov = CorePrepProv False - -- False says that the kinds of two types may differ - -- E.g. we might cast Int to Int#. This is fine - -- because the scrutinee is guaranteed to diverge - - ; return (floats, Cast scrut' co') } - -- This can give rise to - -- Warning: Unsafe coercion: between unboxed and boxed value - -- but it's fine because 'scrut' diverges - --- Eliminate unsafeEqualityProof --- See Note [Unsafe coercions] -cpeRhsE env (Case scrut bndr _ alts) - | isUnsafeEqualityProof scrut - , isDeadBinder bndr -- We can only discard the case if the case-binder - -- is dead. It usually is, but see #18227 - , [Alt _ [co_var] rhs] <- alts - , let Pair ty1 ty2 = coVarTypes co_var - the_co = mkUnivCo prov Nominal (cpSubstTy env ty1) (cpSubstTy env ty2) - prov = CorePrepProv True -- True <=> kind homogeneous - env' = extendCoVarEnv env co_var the_co - = cpeRhsE env' rhs - cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut ; (env', bndr2) <- cpCloneBndr env bndr @@ -1205,14 +1131,10 @@ cpeApp top_env expr in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth CpeApp (Type arg_ty) - -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth - where - arg_ty' = cpSubstTy env arg_ty + -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth CpeApp (Coercion co) - -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth - where - co' = cpSubstCo env co + -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth CpeApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make @@ -1224,9 +1146,7 @@ cpeApp top_env expr rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1) CpeCast co - -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth - where - co' = cpSubstCo env co + -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] CpeTick tickish | tickishPlace tickish == PlaceRuntime @@ -1478,9 +1398,8 @@ But actually, it doesn't, because "turtle"# is already an HNF. Here is the Cmm: Sp = Sp + 8; call Control.Exception.Base.petError_info(R2) args: 8, res: 0, upd: 8; -Besides, with -O, FloatOut will already have already floated "turtle"# to the -top-level, where CSE has a chance to deduplicate strings early (before the -linker, that is). +Besides, with -O, FloatOut will have floated "turtle"# to the top-level, where +CSE has a chance to deduplicate strings early (before the linker, that is). -} -- This is where we arrange that a non-trivial argument is let-bound @@ -1502,11 +1421,32 @@ cpeArg env dmd arg ; if exprIsTrivial arg2 then return (floats2, arg2) else do { v <- newVar arg_ty - ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 + -- See Note [Eta expansion of arguments in CorePrep] + ; let arity | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O2 + , not (is_join_head arg2) + -- See Note [Eta expansion for join points] + -- Eta expanding the join point would + -- introduce crap that we can't generate + -- code for + = case exprEtaExpandArity ao arg2 of + Nothing -> 0 + Just at -> arityTypeArity at + | otherwise + = exprArity arg2 -- this is cheap enough for -O0 and -O1 + arg3 = cpeEtaExpand arity arg2 arg_float = mkFloat env dmd is_unlifted v arg3 ; return (addFloat floats2 arg_float, varToCoreExpr v) } } +is_join_head :: CoreExpr -> Bool +-- ^ Identify the cases where our mishandling described in +-- Note [Eta expansion for join points] would generate crap +is_join_head (Let bs e) = isJoinBind bs || is_join_head e +is_join_head (Cast e _) = is_join_head e +is_join_head (Tick _ e) = is_join_head e +is_join_head (Case _ _ _ alts) = any is_join_head (rhssOfAlts alts) +is_join_head _ = False + {- Note [Floating unlifted arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1624,6 +1564,44 @@ and now we do NOT want eta expansion to give Instead GHC.Core.Opt.Arity.etaExpand gives f = /\a -> \y -> let s = h 3 in g s y +Note [Eta expansion of arguments in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to + + let t = g x + in f t + +We really don't want that `t` to be a thunk! That just wastes runtime, updating +a thunk with a PAP etc. The code generator could in principle allocate a PAP, +but in fact it does not know how to do that -- it's easier just to eta-expand: + + let t = \y. g x y + in f t + +To what arity should we eta-expand the argument? `cpeArg` uses two strategies, +governed by the presence of `-fdo-clever-arg-eta-expansion` (implied by -O): + + 1. Cheap, with -O0: just use `exprArity`. + 2. More clever but expensive, with -O1 -O2: use `exprEtaExpandArity`, + same function the Simplifier uses to eta expand RHSs and lambda bodies. + +The only reason for using (1) rather than (2) is to keep compile times down. +Using (2) in -O0 bumped up compiler allocations by 2-3% in tests T4801 and +T5321*. However, Plan (2) catches cases that (1) misses. +For example (#23083, assuming -fno-pedantic-bottoms): + + let t = case z of __DEFAULT -> g x + in f t + +to + + let t = \y -> case z of __DEFAULT -> g x y + in f t + +Note that there is a missed opportunity in eta expanding `t` earlier, in the +Simplifier: It would allow us to inline `g`, potentially enabling further +simplification. But then we could have inlined `g` into the PAP to begin with, +and that is discussed in #23150; hence we needn't worry about that in CorePrep. -} cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs @@ -1728,24 +1706,36 @@ where marking recursive DFuns (of undecidable *instances*) strict in dictionary -} data FloatingBind - = FloatLet CoreBind -- Rhs of bindings are CpeRhss - -- They are always of lifted type; - -- unlifted ones are done with FloatCase - - | FloatCase - CpeBody -- Always ok-for-speculation - Id -- Case binder - AltCon [Var] -- Single alternative - Bool -- Ok-for-speculation; False of a strict, - -- but lifted binding - - -- | See Note [Floating Ticks in CorePrep] - | FloatTick CoreTickish + -- | Rhs of bindings are CpeRhss + -- They are always of lifted type; + -- unlifted ones are done with FloatCase + = FloatLet CoreBind + + -- | Float a literal string binding. + -- INVARIANT: The `CoreExpr` matches `Lit LitString{}`. + -- It's just more convenient to keep around the expr than the + -- wrapped `ByteString`. + -- This is a special case of `FloatCase` that is unconditionally ok-for-spec. + -- We want to float out strings quite aggressively because they don't + -- allocate. + -- See Note [ANF-ising literal string arguments]. + | FloatString !CoreExpr !Id + + | FloatCase + CpeBody -- ^ Always ok-for-speculation + Id -- ^ Case binder + AltCon [Var] -- ^ Single alternative + Bool -- ^ Ok-for-speculation; False of a strict, + -- but lifted binding + + -- | See Note [Floating Ticks in CorePrep] + | FloatTick CoreTickish data Floats = Floats OkToSpec (OrdList FloatingBind) instance Outputable FloatingBind where ppr (FloatLet b) = ppr b + ppr (FloatString e b) = text "string" <> braces (ppr b <> char '=' <> ppr e) ppr (FloatCase r b k bs ok) = text "case" <> braces (ppr ok) <+> ppr r <+> text "of"<+> ppr b <> text "@" <> case bs of @@ -1774,12 +1764,14 @@ data OkToSpec mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkFloat env dmd is_unlifted bndr rhs + | Lit LitString{} <- rhs = FloatString rhs bndr + | is_strict || ok_for_spec -- See Note [Speculative evaluation] - , not is_hnf = FloatCase rhs bndr DEFAULT [] ok_for_spec + , not is_hnf = FloatCase rhs bndr DEFAULT [] ok_for_spec -- Don't make a case for a HNF binding, even if it's strict -- Otherwise we get case (\x -> e) of ...! - | is_unlifted = FloatCase rhs bndr DEFAULT [] True + | is_unlifted = FloatCase rhs bndr DEFAULT [] True -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled -- because exprOkForSpeculation isn't stable under ANF-ing. See for -- example #19489 where the following unlifted expression: @@ -1794,8 +1786,8 @@ mkFloat env dmd is_unlifted bndr rhs -- -- which isn't ok-for-spec because of the let-expression. - | is_hnf = FloatLet (NonRec bndr rhs) - | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) + | is_hnf = FloatLet (NonRec bndr rhs) + | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) -- See Note [Pin demand info on floats] where is_hnf = exprIsHNF rhs @@ -1814,6 +1806,7 @@ wrapBinds (Floats _ binds) body = foldrOL mk_bind body binds where mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con bs body] + mk_bind (FloatString rhs bndr) body = Case rhs bndr (exprType body) [Alt DEFAULT [] body] mk_bind (FloatLet bind) body = Let bind body mk_bind (FloatTick tickish) body = mkTick tickish body @@ -1821,12 +1814,12 @@ addFloat :: Floats -> FloatingBind -> Floats addFloat (Floats ok_to_spec floats) new_float = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) where - check (FloatLet {}) = OkToSpec - check (FloatCase rhs _ _ _ ok_for_spec) - | Lit LitString{} <- rhs = OkToSpec - | ok_for_spec = IfUnliftedOk - | otherwise = NotOkToSpec - check FloatTick{} = OkToSpec + check FloatLet {} = OkToSpec + check FloatTick{} = OkToSpec + check FloatString{} = OkToSpec + check (FloatCase _ _ _ _ ok_for_spec) + | ok_for_spec = IfUnliftedOk + | otherwise = NotOkToSpec -- The ok-for-speculation flag says that it's safe to -- float this Case out of a let, and thereby do it more eagerly -- We need the IfUnliftedOk flag because it's never ok to float @@ -1834,6 +1827,9 @@ addFloat (Floats ok_to_spec floats) new_float -- There is one exception: String literals! Hence we keep OkToSpec -- See Note [ANF-ising literal string arguments] +mkFloats :: Foldable f => f FloatingBind -> Floats +mkFloats = foldr (flip addFloat) emptyFloats + unitFloat :: FloatingBind -> Floats unitFloat = addFloat emptyFloats @@ -1844,6 +1840,11 @@ appendFloats (Floats spec1 floats1) (Floats spec2 floats2) concatFloats :: [Floats] -> OrdList FloatingBind concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL +partitionOL :: (a -> Bool) -> OrdList a -> (OrdList a, OrdList a) +partitionOL p ol = (toOL l, toOL r) + where + (!l, !r) = partition p (fromOL ol) + combine :: OkToSpec -> OkToSpec -> OkToSpec combine NotOkToSpec _ = NotOkToSpec combine _ NotOkToSpec = NotOkToSpec @@ -1857,6 +1858,7 @@ deFloatTop (Floats _ floats) = foldrOL get [] floats where get (FloatLet b) bs = get_bind b : bs + get (FloatString body var) bs = get_bind (NonRec var body) : bs get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs get b _ = pprPanic "corePrepPgm" (ppr b) @@ -1882,7 +1884,7 @@ canFloat (Floats ok_to_spec fs) rhs go fbs_out (fb@(FloatLet _) : fbs_in) = go (fbs_out `snocOL` fb) fbs_in - go fbs_out (fb@(FloatCase (Lit LitString{}) _ _ _ _) : fbs_in) + go fbs_out (fb at FloatString{} : fbs_in) -- See Note [ANF-ising literal string arguments] = go (fbs_out `snocOL` fb) fbs_in @@ -1902,18 +1904,20 @@ wantFloatNested is_rec dmd rhs_is_unlifted floats rhs -- we don't want to float the case, even if f has arity 2, -- because floating the case would make it evaluated too early. where - worth_floating (Floats _ fs) rhs = exprIsHNF rhs || all is_lit_string fs + worth_floating (Floats _ fs) rhs = exprIsHNF rhs || all isFloatString fs -- Only float out of a RHS that becomes a NF in doing so. Otherwise we -- potentially make 2 thunks (e.g., `[let t = g x, let u = f t]`) where we -- had a single nested one before (e.g., `[let u = let t = g x in f t]`. -- We relax when it's a LitString that we float out, because that doesn't -- allocate. See Note [ANF-ising literal string arguments] - -- The LitString check is a bit crude, because wantFloatNested is + -- The FloatString check is a bit crude, because wantFloatNested is -- all-or-nothing. We might want to refactor to something more like -- FloatOut.partitionByLevel for selective floating, but compiler perf -- implications are unclear. - is_lit_string (FloatCase (Lit LitString{}) _ _ _ _) = True - is_lit_string _ = False + +isFloatString :: FloatingBind -> Bool +isFloatString FloatString{} = True +isFloatString _ = False allLazyTop :: Floats -> Bool allLazyTop (Floats OkToSpec _) = True @@ -2007,6 +2011,11 @@ data CorePrepConfig = CorePrepConfig , cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr) -- ^ Convert some numeric literals (Integer, Natural) into their final -- Core form. + + , cp_arityOpts :: !(Maybe ArityOpts) + -- ^ Configuration for arity analysis ('exprEtaExpandArity'). + -- See Note [Eta expansion of arguments in CorePrep] + -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead } data CorePrepEnv @@ -2017,6 +2026,7 @@ data CorePrepEnv -- enabled we instead produce an 'error' expression to catch -- the case where a function we think should bottom -- unexpectedly returns. + , cpe_env :: IdEnv CoreExpr -- Clone local Ids -- ^ This environment is used for three operations: -- @@ -2030,8 +2040,6 @@ data CorePrepEnv -- see Note [lazyId magic], Note [Inlining in CorePrep] -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076) - , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv] - , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation] } @@ -2039,7 +2047,6 @@ mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv mkInitialCorePrepEnv cfg = CPE { cpe_config = cfg , cpe_env = emptyVarEnv - , cpe_tyco_env = Nothing , cpe_rec_ids = emptyUnVarSet } @@ -2066,117 +2073,6 @@ enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv enterRecGroupRHSs env grp = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) } ------------------------------------------------------------------------------- --- CpeTyCoEnv --- --------------------------------------------------------------------------- - -{- Note [CpeTyCoEnv] -~~~~~~~~~~~~~~~~~~~~ -The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution -for type and coercion variables - -* We need the coercion substitution to support the elimination of - unsafeEqualityProof (see Note [Unsafe coercions]) - -* We need the type substitution in case one of those unsafe - coercions occurs in the kind of tyvar binder (sigh) - -We don't need an in-scope set because we don't clone any of these -binders at all, so no new capture can take place. - -The cpe_tyco_env is almost always empty -- it only gets populated -when we get under an usafeEqualityProof. Hence the Maybe CpeTyCoEnv, -which makes everything into a no-op in the common case. --} - -data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv - -emptyTCE :: CpeTyCoEnv -emptyTCE = TCE emptyTvSubstEnv emptyCvSubstEnv - -extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv -extend_tce_cv (TCE tv_env cv_env) cv co - = TCE tv_env (extendVarEnv cv_env cv co) - -extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv -extend_tce_tv (TCE tv_env cv_env) tv ty - = TCE (extendVarEnv tv_env tv ty) cv_env - -lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -lookup_tce_cv (TCE _ cv_env) cv - = case lookupVarEnv cv_env cv of - Just co -> co - Nothing -> mkCoVarCo cv - -lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type -lookup_tce_tv (TCE tv_env _) tv - = case lookupVarEnv tv_env tv of - Just ty -> ty - Nothing -> mkTyVarTy tv - -extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv -extendCoVarEnv cpe@(CPE { cpe_tyco_env = mb_tce }) cv co - = cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) } - where - tce = mb_tce `orElse` emptyTCE - - -cpSubstTy :: CorePrepEnv -> Type -> Type -cpSubstTy (CPE { cpe_tyco_env = mb_env }) ty - = case mb_env of - Just env -> runIdentity (subst_ty env ty) - Nothing -> ty - -cpSubstCo :: CorePrepEnv -> Coercion -> Coercion -cpSubstCo (CPE { cpe_tyco_env = mb_env }) co - = case mb_env of - Just tce -> runIdentity (subst_co tce co) - Nothing -> co - -subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity -subst_tyco_mapper = TyCoMapper - { tcm_tyvar = \env tv -> return (lookup_tce_tv env tv) - , tcm_covar = \env cv -> return (lookup_tce_cv env cv) - , tcm_hole = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole) - , tcm_tycobinder = \env tcv _vis -> if isTyVar tcv - then return (subst_tv_bndr env tcv) - else return (subst_cv_bndr env tcv) - , tcm_tycon = \tc -> return tc } - -subst_ty :: CpeTyCoEnv -> Type -> Identity Type -subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion -(subst_ty, _, subst_co, _) = mapTyCoX subst_tyco_mapper - -cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar) -cpSubstTyVarBndr env@(CPE { cpe_tyco_env = mb_env }) tv - = case mb_env of - Nothing -> (env, tv) - Just tce -> (env { cpe_tyco_env = Just tce' }, tv') - where - (tce', tv') = subst_tv_bndr tce tv - -subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar) -subst_tv_bndr tce tv - = (extend_tce_tv tce tv (mkTyVarTy tv'), tv') - where - tv' = mkTyVar (tyVarName tv) kind' - kind' = runIdentity $ subst_ty tce $ tyVarKind tv - -cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar) -cpSubstCoVarBndr env@(CPE { cpe_tyco_env = mb_env }) cv - = case mb_env of - Nothing -> (env, cv) - Just tce -> (env { cpe_tyco_env = Just tce' }, cv') - where - (tce', cv') = subst_cv_bndr tce cv - -subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar) -subst_cv_bndr tce cv - = (extend_tce_cv tce cv (mkCoVarCo cv'), cv') - where - cv' = mkCoVar (varName cv) ty' - ty' = runIdentity (subst_ty tce $ varType cv) - ------------------------------------------------------------------------------ -- Cloning binders -- --------------------------------------------------------------------------- @@ -2186,12 +2082,8 @@ cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) cpCloneBndr env bndr - | isTyVar bndr - = return (cpSubstTyVarBndr env bndr) - - | isCoVar bndr - = return (cpSubstCoVarBndr env bndr) - + | isTyCoVar bndr + = return (env, bndr) | otherwise = do { bndr' <- clone_it bndr @@ -2211,8 +2103,7 @@ cpCloneBndr env bndr clone_it bndr | isLocalId bndr = do { uniq <- getUniqueM - ; let ty' = cpSubstTy env (idType bndr) - ; return (setVarUnique (setIdType bndr ty') uniq) } + ; return (setVarUnique bndr uniq) } | otherwise -- Top level things, which we don't want -- to clone, have become GlobalIds by now ===================================== compiler/GHC/Driver/Config/CoreToStg/Prep.hs ===================================== @@ -9,6 +9,7 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Config.Core.Lint +import GHC.Driver.Config.Core.Opt.Arity import GHC.Tc.Utils.Env import GHC.Types.Var import GHC.Utils.Outputable ( alwaysQualify ) @@ -17,14 +18,18 @@ import GHC.CoreToStg.Prep initCorePrepConfig :: HscEnv -> IO CorePrepConfig initCorePrepConfig hsc_env = do + let dflags = hsc_dflags hsc_env convertNumLit <- do - let platform = targetPlatform $ hsc_dflags hsc_env + let platform = targetPlatform dflags home_unit = hsc_home_unit hsc_env lookup_global = lookupGlobal hsc_env mkConvertNumLiteral platform home_unit lookup_global return $ CorePrepConfig - { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env + { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags , cp_convertNumLit = convertNumLit + , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags + then Just (initArityOpts dflags) + else Nothing } initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -262,6 +262,7 @@ data GeneralFlag | Opt_SpecConstr | Opt_SpecConstrKeen | Opt_DoLambdaEtaExpansion + | Opt_DoCleverArgEtaExpansion -- More sophisticated eta expansion of arguments in CorePrep | Opt_IgnoreAsserts | Opt_DoEtaReduction | Opt_CaseMerge ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3467,6 +3467,7 @@ fFlagsDeps = [ Opt_DmdTxDictSel "effect is now unconditionally enabled", flagSpec "do-eta-reduction" Opt_DoEtaReduction, flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, + flagSpec "do-clever-arg-eta-expansion" Opt_DoCleverArgEtaExpansion, flagSpec "eager-blackholing" Opt_EagerBlackHoling, flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, @@ -4059,6 +4060,7 @@ optLevelFlags :: [([Int], GeneralFlag)] -- Default settings of flags, before any command-line overrides optLevelFlags -- see Note [Documenting optimisation flags] = [ ([0,1,2], Opt_DoLambdaEtaExpansion) + , ([1,2], Opt_DoCleverArgEtaExpansion) , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] , ([0,1,2], Opt_LlvmTBAA) , ([0,1,2], Opt_ProfManualCcs ) ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -1748,7 +1748,6 @@ freeNamesIfProv :: IfaceUnivCoProv -> NameSet freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _) = emptyNameSet -freeNamesIfProv (IfaceCorePrepProv _) = emptyNameSet freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr ===================================== compiler/GHC/Iface/Type.hs ===================================== @@ -402,7 +402,6 @@ data IfaceUnivCoProv = IfacePhantomProv IfaceCoercion | IfaceProofIrrelProv IfaceCoercion | IfacePluginProv String - | IfaceCorePrepProv Bool -- See defn of CorePrepProv {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -624,7 +623,6 @@ substIfaceType env ty go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) go_prov co@(IfacePluginProv _) = co - go_prov co@(IfaceCorePrepProv _) = co substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args @@ -1860,8 +1858,6 @@ pprIfaceUnivCoProv (IfaceProofIrrelProv co) = text "irrel" <+> pprParendIfaceCoercion co pprIfaceUnivCoProv (IfacePluginProv s) = text "plugin" <+> doubleQuotes (text s) -pprIfaceUnivCoProv (IfaceCorePrepProv _) - = text "CorePrep" ------------------- instance Outputable IfaceTyCon where @@ -2229,9 +2225,6 @@ instance Binary IfaceUnivCoProv where put_ bh (IfacePluginProv a) = do putByte bh 3 put_ bh a - put_ bh (IfaceCorePrepProv a) = do - putByte bh 4 - put_ bh a get bh = do tag <- getByte bh @@ -2242,8 +2235,6 @@ instance Binary IfaceUnivCoProv where return $ IfaceProofIrrelProv a 3 -> do a <- get bh return $ IfacePluginProv a - 4 -> do a <- get bh - return (IfaceCorePrepProv a) _ -> panic ("get IfaceUnivCoProv " ++ show tag) ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1520,7 +1520,6 @@ tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str -tcIfaceUnivCoProv (IfaceCorePrepProv b) = return $ CorePrepProv b {- ************************************************************************ ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -53,7 +53,6 @@ import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad ( unless, void ) import Control.Arrow ( first ) @@ -1028,7 +1027,7 @@ cgIdApp fun_id args = do (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun)) fun - EnterIt -> assert (null args) $ -- Discarding arguments + EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ -- Discarding arguments emitEnter fun SlowCall -> do -- A slow function call via the RTS apply routines ===================================== compiler/GHC/Tc/TyCl/Utils.hs ===================================== @@ -156,7 +156,6 @@ synonymTyConsOfType ty go_prov (PhantomProv co) = go_co co go_prov (ProofIrrelProv co) = go_co co go_prov (PluginProv _) = emptyNameEnv - go_prov (CorePrepProv _) = emptyNameEnv go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc | otherwise = emptyNameEnv ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -1578,7 +1578,6 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co go_prov dv (PhantomProv co) = go_co dv co go_prov dv (ProofIrrelProv co) = go_co dv co go_prov dv (PluginProv _) = return dv - go_prov dv (CorePrepProv _) = return dv go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs go_cv dv@(DV { dv_cvs = cvs }) cv ===================================== compiler/GHC/Utils/Trace.hs ===================================== @@ -8,6 +8,7 @@ module GHC.Utils.Trace , pprSTrace , pprTraceException , warnPprTrace + , warnPprTraceM , pprTraceUserWarning , trace ) @@ -84,6 +85,9 @@ warnPprTrace True s msg x (text s $$ msg $$ withFrozenCallStack traceCallStackDoc ) x +warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f () +warnPprTraceM b s doc = withFrozenCallStack warnPprTrace b s doc (pure ()) + -- | For when we want to show the user a non-fatal WARNING so that they can -- report a GHC bug, but don't want to panic. pprTraceUserWarning :: HasCallStack => SDoc -> a -> a ===================================== docs/users_guide/using-optimisation.rst ===================================== @@ -467,6 +467,17 @@ by saying ``-fno-wombat``. Eta-expand let-bindings to increase their arity. +.. ghc-flag:: -fdo-clever-arg-eta-expansion + :shortdesc: Enable sophisticated argument eta-expansion. Implied by :ghc-flag:`-O2`. + :type: dynamic + :reverse: -fno-do-clever-arg-eta-expansion + :category: + + :default: off + + Eta-expand arguments to increase their arity to avoid allocating unnecessary + thunks for them. + .. ghc-flag:: -feager-blackholing :shortdesc: Turn on :ref:`eager blackholing ` :type: dynamic ===================================== libraries/base/Unsafe/Coerce.hs ===================================== @@ -88,13 +88,13 @@ several ways (U1) unsafeEqualityProof is /never/ inlined. -(U2) In CoreToStg.Prep, we transform +(U2) In CoreToStg, we transform case unsafeEqualityProof of UnsafeRefl g -> blah ==> - blah[unsafe-co/g] + blah - This eliminates the overhead of evaluating the unsafe - equality proof. + This eliminates the overhead of evaluating the unsafe equality proof. + (It follows that the Case is trivial iff `blah` is.) Any /other/ occurrence of unsafeEqualityProof is left alone. For example you could write @@ -131,9 +131,11 @@ several ways Floating the case is OK here, even though it broadens the scope, because we are done with simplification. -(U4) Ditto GHC.Core.Unfold.inlineBoringOk we want to treat - the RHS of unsafeCoerce as very small; see - Note [Inline unsafeCoerce] in that module. +(U4) We regard `case unsafeEqualityProof of UnsafeRefl -> rhs` as trivial iff + `rhs` is. One reason is that we want to treat the RHS of unsafeCoerce as + very small; see Note [Inline unsafeCoerce] in GHC.Core.Unfold. + Another is that we do not want to allocate a thunk in CorePrep when we + wouldn't do so for `rhs`, because we discard the case in CoreToStg anyway. (U5) The definition of unsafeEqualityProof in Unsafe.Coerce looks very strange: ===================================== testsuite/tests/simplCore/should_compile/T23083.hs ===================================== @@ -0,0 +1,10 @@ +module T23083 where + +-- Just ($), but NOINLINE so that we don't inline it eagerly, subverting the +-- test case +($$) :: (a -> b) -> a -> b +($$) f x = f x +{-# NOINLINE ($$) #-} + +g :: ((Integer -> Integer) -> Integer) -> (Integer -> Integer) -> Integer +g f h = f (h `seq` (h $$)) ===================================== testsuite/tests/simplCore/should_compile/T23083.stderr ===================================== @@ -0,0 +1,47 @@ + +==================== CorePrep ==================== +Result size of CorePrep = {terms: 34, types: 34, coercions: 0, joins: 0/1} + +-- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0} +(T23083.$$) [InlPrag=NOINLINE] :: forall a b. (a -> b) -> a -> b +[GblId, Arity=2, Str=<1C(1,L)>, Unf=OtherCon []] +(T23083.$$) = \ (@a) (@b) (f [Occ=Once1!] :: a -> b) (x [Occ=Once1] :: a) -> f x + +-- RHS size: {terms: 12, types: 12, coercions: 0, joins: 0/1} +T23083.g :: ((GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) -> (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer +[GblId, Arity=2, Str=<1C(1,L)>, Unf=OtherCon []] +T23083.g + = \ (f [Occ=Once1!] :: (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) (h [Occ=OnceL1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> + let { + sat [Occ=Once1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer + [LclId] + sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> T23083.$$ @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in + f sat + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T23083.$trModule4 :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +T23083.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T23083.$trModule3 :: GHC.Types.TrName +[GblId, Unf=OtherCon []] +T23083.$trModule3 = GHC.Types.TrNameS T23083.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T23083.$trModule2 :: GHC.Prim.Addr# +[GblId, Unf=OtherCon []] +T23083.$trModule2 = "T23083"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T23083.$trModule1 :: GHC.Types.TrName +[GblId, Unf=OtherCon []] +T23083.$trModule1 = GHC.Types.TrNameS T23083.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T23083.$trModule :: GHC.Types.Module +[GblId, Unf=OtherCon []] +T23083.$trModule = GHC.Types.Module T23083.$trModule3 T23083.$trModule1 + + + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -477,3 +477,4 @@ test('T23012', normal, compile, ['-O']) test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques']) test('T23024', normal, multimod_compile, ['T23024', '-O -v0']) test('T23026', normal, compile, ['-O']) +test('T23083', [ grep_errmsg(r'eta.+::.+Integer') ], compile, ['-O -ddump-prep -dsuppress-uniques -dppr-cols=99999']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3bbd970a15e892833b551ce95a74fa7e803b3a0c...fd286b5029a42ddb70bb4ae21d000fd03889fd49 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3bbd970a15e892833b551ce95a74fa7e803b3a0c...fd286b5029a42ddb70bb4ae21d000fd03889fd49 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 21:36:48 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 02 May 2023 17:36:48 -0400 Subject: [Git][ghc/ghc][wip/T19146] 2 commits: rts: Don't sanity-check StgTSO.global_link Message-ID: <64518270c9dcc_3c911551f681525d9@gitlab.mail> Ben Gamari pushed to branch wip/T19146 at Glasgow Haskell Compiler / GHC Commits: 7b175e36 by Ben Gamari at 2023-05-02T17:36:43-04:00 rts: Don't sanity-check StgTSO.global_link See Note [Avoid dangling global_link pointers]. Fixes #19146. - - - - - e7c285ce by Ben Gamari at 2023-05-02T17:36:43-04:00 rts: Introduce printGlobalThreads - - - - - 4 changed files: - rts/Threads.c - rts/Threads.h - rts/include/MachDeps.h - rts/sm/Sanity.c Changes: ===================================== rts/Threads.c ===================================== @@ -1008,6 +1008,20 @@ printAllThreads(void) } } +void +printGlobalThreads(void) +{ + for (uint32_t g = 0; g < RtsFlags.GcFlags.generations; g++) { + debugBelch("\ngen %d\n", g); + for (StgTSO *t = generations[g].threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu)\n", t, t->id); + } + for (StgTSO *t = generations[g].old_threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu) (old)\n", t, t->id); + } + } +} + // useful from gdb void printThreadQueue(StgTSO *t) ===================================== rts/Threads.h ===================================== @@ -46,6 +46,7 @@ bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value); void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); void printAllThreads (void); +void printGlobalThreads(void); void printThreadQueue (StgTSO *t); #endif ===================================== rts/include/MachDeps.h ===================================== @@ -107,9 +107,11 @@ #endif #endif -// This is the bit-pattern used by the RTS to clear freed memory -// when +RTS -DZ is in use. The LOOKS_LIKE_*_PTR utilities use this -// macro to catch clearly invalid pointers +/* + * INVALID_GHC_POINTER is the bit-pattern used by the RTS to clear freed memory + * when +RTS -DZ is in use. The LOOKS_LIKE_*_PTR utilities use this macro to + * catch clearly invalid pointers + */ #if !defined(INVALID_GHC_POINTER) #if SIZEOF_HSWORD == 4 #define INVALID_GHC_POINTER 0xaaaaaaaa ===================================== rts/sm/Sanity.c ===================================== @@ -737,6 +737,27 @@ checkSTACK (StgStack *stack) checkStackChunk(sp, stack_end); } +/* + * Note [Avoid dangling global_link pointers] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * TSOs are a bit odd in that they have a global_link pointer field + * which is not scavenged by the GC. This field is used to track the + * generations[_].[old_]threads lists and is ultimately updated by + * MarkWeak.c:tidyThreadList. + + * Typically the fact that this field is not scavenged is fine as all reachable + * TSOs on the heap are guaranteed to be on some generation's thread list and + * therefore will be scavenged by tidyThreadList. However, the sanity checker + * poses a bit of a challenge here as it walks heap blocks directly and + * therefore may encounter TSOs which aren't reachable via the heap. + * For this reason, checkTSO does not check global_link. Instead, we only do + * so in checkGlobalTSOList, which by definition will only look at + * threads which are reachable via a thread list (and therefore must have won + * the forwarding-pointer race). + * + * See #19146. + */ + void checkTSO(StgTSO *tso) { @@ -761,9 +782,11 @@ checkTSO(StgTSO *tso) ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->stackobj)); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && - (tso->global_link == END_TSO_QUEUE || - get_itbl((StgClosure*)tso->global_link)->type == TSO)); + + // This assertion is sadly not viable. See Note [Sanity-checking global_link]. + //ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && + // (tso->global_link == END_TSO_QUEUE || + // get_itbl((StgClosure*)tso->global_link)->type == TSO)); if (tso->label) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->label)); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/280bace467a531d00be6e5d448c528b09b0dbc5a...e7c285ce394d4e856045a72c597d8754afab9ba0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/280bace467a531d00be6e5d448c528b09b0dbc5a...e7c285ce394d4e856045a72c597d8754afab9ba0 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 2 21:37:40 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 02 May 2023 17:37:40 -0400 Subject: [Git][ghc/ghc][wip/T19146] 3 commits: rts: Assert that pointers aren't cleared Message-ID: <645182a4cee11_3c911551e14152921@gitlab.mail> Ben Gamari pushed to branch wip/T19146 at Glasgow Haskell Compiler / GHC Commits: 5347837a by Ben Gamari at 2023-05-02T17:37:33-04:00 rts: Assert that pointers aren't cleared This turns many segmentation faults into much easier-to-debug assertion failures by ensuring that LOOKS_LIKE_*_PTR checks recognize bit-patterns produced by `+RTS -DZ` clearing as invalid pointers. This is a bit ad-hoc but this is the debug runtime. - - - - - 3dbd45e3 by Ben Gamari at 2023-05-02T17:37:33-04:00 rts: Don't sanity-check StgTSO.global_link See Note [Avoid dangling global_link pointers]. Fixes #19146. - - - - - 4a117ab9 by Ben Gamari at 2023-05-02T17:37:33-04:00 rts: Introduce printGlobalThreads - - - - - 6 changed files: - rts/Threads.c - rts/Threads.h - rts/include/Cmm.h - rts/include/MachDeps.h - rts/include/rts/storage/ClosureMacros.h - rts/sm/Sanity.c Changes: ===================================== rts/Threads.c ===================================== @@ -1008,6 +1008,20 @@ printAllThreads(void) } } +void +printGlobalThreads(void) +{ + for (uint32_t g = 0; g < RtsFlags.GcFlags.generations; g++) { + debugBelch("\ngen %d\n", g); + for (StgTSO *t = generations[g].threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu)\n", t, t->id); + } + for (StgTSO *t = generations[g].old_threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu) (old)\n", t, t->id); + } + } +} + // useful from gdb void printThreadQueue(StgTSO *t) ===================================== rts/Threads.h ===================================== @@ -46,6 +46,7 @@ bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value); void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); void printAllThreads (void); +void printGlobalThreads(void); void printThreadQueue (StgTSO *t); #endif ===================================== rts/include/Cmm.h ===================================== @@ -605,16 +605,20 @@ #define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK) #define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT) +#define LOOKS_LIKE_PTR(p) ((p) != NULL && (p) != INVALID_GHC_POINTER) + /* Debugging macros */ #define LOOKS_LIKE_INFO_PTR(p) \ - ((p) != NULL && \ + (LOOKS_LIKE_PTR(p) && \ LOOKS_LIKE_INFO_PTR_NOT_NULL(p)) #define LOOKS_LIKE_INFO_PTR_NOT_NULL(p) \ ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) && \ (TO_W_(%INFO_TYPE(%STD_INFO(p))) < N_CLOSURE_TYPES)) -#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) +#define LOOKS_LIKE_CLOSURE_PTR(p) \ + ( LOOKS_LIKE_PTR(p) && \ + LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) /* * The layout of the StgFunInfoExtra part of an info table changes ===================================== rts/include/MachDeps.h ===================================== @@ -107,6 +107,19 @@ #endif #endif +/* + * INVALID_GHC_POINTER is the bit-pattern used by the RTS to clear freed memory + * when +RTS -DZ is in use. The LOOKS_LIKE_*_PTR utilities use this macro to + * catch clearly invalid pointers + */ +#if !defined(INVALID_GHC_POINTER) +#if SIZEOF_HSWORD == 4 +#define INVALID_GHC_POINTER 0xaaaaaaaa +#else +#define INVALID_GHC_POINTER 0xaaaaaaaaaaaaaaaa +#endif +#endif + #if !defined(TAG_BITS) #if SIZEOF_HSWORD == 4 #define TAG_BITS 2 ===================================== rts/include/rts/storage/ClosureMacros.h ===================================== @@ -270,6 +270,12 @@ EXTERN_INLINE StgClosure *TAG_CLOSURE(StgWord tag,StgClosure * p) make sense... -------------------------------------------------------------------------- */ +EXTERN_INLINE bool LOOKS_LIKE_PTR (const void* p); +EXTERN_INLINE bool LOOKS_LIKE_PTR (const void* p) +{ + return p && (p != (const void*) INVALID_GHC_POINTER); +} + EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p); EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p) { @@ -280,12 +286,13 @@ EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p) EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR (StgWord p); EXTERN_INLINE bool LOOKS_LIKE_INFO_PTR (StgWord p) { - return p && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p)); + return LOOKS_LIKE_PTR((const void*) p) && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p)); } EXTERN_INLINE bool LOOKS_LIKE_CLOSURE_PTR (const void *p); EXTERN_INLINE bool LOOKS_LIKE_CLOSURE_PTR (const void *p) { + if (!LOOKS_LIKE_PTR(p)) return false; const StgInfoTable *info = RELAXED_LOAD(&UNTAG_CONST_CLOSURE((const StgClosure *) (p))->header.info); return LOOKS_LIKE_INFO_PTR((StgWord) info); } ===================================== rts/sm/Sanity.c ===================================== @@ -737,6 +737,27 @@ checkSTACK (StgStack *stack) checkStackChunk(sp, stack_end); } +/* + * Note [Avoid dangling global_link pointers] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * TSOs are a bit odd in that they have a global_link pointer field + * which is not scavenged by the GC. This field is used to track the + * generations[_].[old_]threads lists and is ultimately updated by + * MarkWeak.c:tidyThreadList. + + * Typically the fact that this field is not scavenged is fine as all reachable + * TSOs on the heap are guaranteed to be on some generation's thread list and + * therefore will be scavenged by tidyThreadList. However, the sanity checker + * poses a bit of a challenge here as it walks heap blocks directly and + * therefore may encounter TSOs which aren't reachable via the heap. + * For this reason, checkTSO does not check global_link. Instead, we only do + * so in checkGlobalTSOList, which by definition will only look at + * threads which are reachable via a thread list (and therefore must have won + * the forwarding-pointer race). + * + * See #19146. + */ + void checkTSO(StgTSO *tso) { @@ -761,9 +782,11 @@ checkTSO(StgTSO *tso) ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->stackobj)); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && - (tso->global_link == END_TSO_QUEUE || - get_itbl((StgClosure*)tso->global_link)->type == TSO)); + + // This assertion is sadly not viable. See Note [Sanity-checking global_link]. + //ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && + // (tso->global_link == END_TSO_QUEUE || + // get_itbl((StgClosure*)tso->global_link)->type == TSO)); if (tso->label) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->label)); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7c285ce394d4e856045a72c597d8754afab9ba0...4a117ab986e128d4f409c6be94a0d7f1c6d8912b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7c285ce394d4e856045a72c597d8754afab9ba0...4a117ab986e128d4f409c6be94a0d7f1c6d8912b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 00:30:46 2023 From: gitlab at gitlab.haskell.org (Ryan Scott (@RyanGlScott)) Date: Tue, 02 May 2023 20:30:46 -0400 Subject: [Git][ghc/ghc][wip/T23329] Fix type variable substitution in gen_Newtype_fam_insts Message-ID: <6451ab361745c_3c911597950168920@gitlab.mail> Ryan Scott pushed to branch wip/T23329 at Glasgow Haskell Compiler / GHC Commits: 134d4e65 by Ryan Scott at 2023-05-02T20:23:14-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 5 changed files: - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/TyCl/Class.hs - + testsuite/tests/deriving/should_compile/T23329.hs - + testsuite/tests/deriving/should_compile/T23329_M.hs - testsuite/tests/deriving/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -46,6 +46,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate( newFamInst ) import GHC.Tc.Utils.Env @@ -2100,8 +2101,8 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty newFamInst SynFamilyInst axiom where fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs + (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs + (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -22,6 +22,7 @@ module GHC.Tc.TyCl.Class , instDeclCtxt2 , instDeclCtxt3 , tcATDefault + , substATBndrs ) where @@ -58,7 +59,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var -import GHC.Types.Var.Env +import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) import GHC.Types.SrcLoc import GHC.Types.Basic @@ -501,8 +502,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) -- instance C [x] -- Then we want to generate the decl: type F [x] b = () | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) + = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc) rhs' = substTyUnchecked subst' rhs_ty tcv' = tyCoVarsOfTypesList pat_tys' (tv', cv') = partition isTyVar tcv' @@ -525,14 +525,73 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) | otherwise -- defs = Nothing = do { warnMissingAT (tyConName fam_tc) ; return [] } + +-- | Apply a substitution to the type variable binders of an associated type +-- family. This is used to compute default instances for associated type +-- families (see 'tcATDefault') as well as @newtype at -derived associated type +-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate"). +-- +-- As a concrete example, consider the following class and associated type +-- family: +-- +-- @ +-- class C k (a :: k) where +-- type F k a (b :: k) :: Type +-- type F j p q = (Proxy @j p, Proxy @j (q :: j)) +-- @ +-- +-- If a user defines this instance: +-- +-- @ +-- instance C (Type -> Type) Maybe where {} +-- @ +-- +-- Then in order to typecheck the default @F@ instance, we must apply the +-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which +-- are @[k, a, (b :: k)]@. The result should look like this: +-- +-- @ +-- type F (Type -> Type) Maybe (b :: Type -> Type) = +-- (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type)) +-- @ +-- +-- Making this work requires some care. There are two cases: +-- +-- 1. If we encounter a type variable in the domain of the substitution (e.g., +-- @k@ or @a@), then we apply the substitution directly. +-- +-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn +-- @b :: k@ to @b :: Type -> Type@). We then return an extended substitution +-- where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@). +-- +-- This step is important to do in case there are later occurrences of @b@, +-- which we must ensure have the correct kind. Otherwise, we might end up +-- with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the +-- default instance, which would be completely wrong. +-- +-- Contrast 'substATBndrs' function with similar substitution functions: +-- +-- * 'substTyVars' does not substitute into the kinds of each type variable, +-- nor does it extend the substitution. 'substTyVars' is meant for occurrences +-- of type variables, whereas 'substATBndr's is meant for binders. +-- +-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution, +-- but it does not apply the substitution to the variables themselves. As +-- such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of +-- 'Type's. +substATBndrs :: Subst -> [TyVar] -> (Subst, [Type]) +substATBndrs = mapAccumL substATBndr where - subst_tv subst tc_tv + substATBndr :: Subst -> TyVar -> (Subst, Type) + substATBndr subst tc_tv + -- Case (1) in the Haddocks | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty) + -- Case (2) in the Haddocks | otherwise = (extendTvSubst subst tc_tv ty', ty') where - ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) + ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) warnMissingAT :: Name -> TcM () warnMissingAT name ===================================== testsuite/tests/deriving/should_compile/T23329.hs ===================================== @@ -0,0 +1,9 @@ +module T23329 where + +import Data.Kind (Type) +import Data.Proxy (Proxy(Proxy)) + +import T23329_M + +foo :: () +foo = myMethod @Type @MyMaybe @() () Proxy Proxy ===================================== testsuite/tests/deriving/should_compile/T23329_M.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module T23329_M where + +import Data.Kind (Type) +import Data.Proxy (Proxy) + +class MyClass (f :: k -> Type) where + type MyTypeFamily f (i :: k) :: Type + myMethod :: MyTypeFamily f i -> Proxy f -> Proxy i -> () + +instance MyClass Maybe where + type MyTypeFamily Maybe i = () + myMethod = undefined + +newtype MyMaybe a = MyMaybe (Maybe a) + deriving MyClass ===================================== testsuite/tests/deriving/should_compile/all.T ===================================== @@ -141,3 +141,4 @@ test('T20994', normal, compile, ['']) test('T22167', normal, compile, ['']) test('T22696a', normal, compile, ['']) test('T22696c', normal, compile, ['']) +test('T23329', normal, multimod_compile, ['T23329', '-v0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/134d4e6583a3c6b0659eeeddd1ab969d47eab42c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/134d4e6583a3c6b0659eeeddd1ab969d47eab42c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 06:06:00 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 May 2023 02:06:00 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Add structured error messages for GHC.Rename.Names Message-ID: <6451f9c8e0cfa_3c911515e88c9819878b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 0459e0c3 by Ben Orchard at 2023-05-03T02:05:30-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - 49f2332b by Bodigrim at 2023-05-03T02:05:34-04:00 Document instances of Double - - - - - 5e9ce68d by Sylvain Henry at 2023-05-03T02:05:45-04:00 Bump Cabal submodule (#22356) - - - - - 30dc982c by sheaf at 2023-05-03T02:05:50-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - f64c919d by amesgen at 2023-05-03T02:05:55-04:00 Fix unlit path in cross bindists - - - - - 30 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Lit.hs - docs/users_guide/9.8.1-notes.rst - + docs/users_guide/exts/extended_literals.rst - docs/users_guide/exts/literals.rst - docs/users_guide/exts/primitives.rst - docs/users_guide/exts/stolen_syntax.rst - hadrian/bindist/Makefile - libraries/Cabal - libraries/base/GHC/Float.hs - libraries/base/GHC/Real.hs - libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs - testsuite/tests/deriving/should_compile/T17324.stderr - testsuite/tests/driver/T4437.hs - testsuite/tests/driver/t22391/t22391.stderr - testsuite/tests/driver/t22391/t22391j.stderr - + testsuite/tests/extendedliterals/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef4c44f038657ae3a51e859a5e571386a5be34d5...f64c919de724052ad7943615e7aeabe9eda3b9f0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ef4c44f038657ae3a51e859a5e571386a5be34d5...f64c919de724052ad7943615e7aeabe9eda3b9f0 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 08:33:17 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Wed, 03 May 2023 04:33:17 -0400 Subject: [Git][ghc/ghc][wip/t22884] Suggestions Message-ID: <64521c4da0419_3c911519fceb582215c5@gitlab.mail> Matthew Pickering pushed to branch wip/t22884 at Glasgow Haskell Compiler / GHC Commits: f936f148 by sheaf at 2023-05-03T08:33:15+00:00 Suggestions - - - - - 2 changed files: - compiler/GHC/Iface/Errors/Ppr.hs - ghc/GHCi/UI/Exception.hs Changes: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -135,20 +135,20 @@ cantFindError :: IfaceMessageOpts -> FindingModuleOrInterface -> CantFindInstalled -> SDoc -cantFindError opts = cantFindErrorX (pkgHiddenHint (const empty) (ifaceBuildingCabalPackage opts)) (mayShowLocations "-v" (ifaceShowTriedFiles opts)) - where +cantFindError opts = + cantFindErrorX + (pkgHiddenHint (const empty) (ifaceBuildingCabalPackage opts)) + (mayShowLocations "-v" (ifaceShowTriedFiles opts)) -pkgHiddenHint :: (UnitInfo -> SDoc) -> BuildingCabalPackage - -> Maybe UnitInfo -> SDoc -pkgHiddenHint hint using_cabal (Just pkg) - | using_cabal == YesBuildingCabalPackage - = text "Perhaps you need to add" <+> - quotes (ppr (unitPackageName pkg)) <+> - text "to the build-depends in your .cabal file." - | otherwise - = hint pkg -pkgHiddenHint _ _ Nothing = empty +pkgHiddenHint :: (UnitInfo -> SDoc) -> BuildingCabalPackage + -> UnitInfo -> SDoc +pkgHiddenHint _hint YesBuildingCabalPackage pkg + = text "Perhaps you need to add" <+> + quotes (ppr (unitPackageName pkg)) <+> + text "to the build-depends in your .cabal file." +pkgHiddenHint hint _not_cabal pkg + = hint pkg mayShowLocations :: String -> Bool -> [FilePath] -> SDoc mayShowLocations option verbose files @@ -161,8 +161,8 @@ mayShowLocations option verbose files -- | General version of cantFindError which has some holes which allow GHC/GHCi to display slightly different -- error messages. -cantFindErrorX :: (Maybe UnitInfo -> SDoc) -> ([FilePath] -> SDoc) -> FindingModuleOrInterface -> CantFindInstalled -> SDoc -cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstalled mod_name cfir) = +cantFindErrorX :: (UnitInfo -> SDoc) -> ([FilePath] -> SDoc) -> FindingModuleOrInterface -> CantFindInstalled -> SDoc +cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInstalled mod_name cfir) = let ambig = isAmbiguousInstalledReason cfir find_or_load = isLoadOrFindReason cfir ppr_what = prettyCantFindWhat find_or_load mod_or_interface ambig @@ -194,7 +194,7 @@ cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstal MissingPackageWayFiles build pkg files -> text "Perhaps you haven't installed the " <> text build <+> text "libraries for package " <> quotes (ppr pkg) <> char '?' $$ - mayShowLocations files + may_show_locations files ModuleSuggestion ms fps -> let pp_suggestions :: [ModuleSuggestion] -> SDoc @@ -236,7 +236,7 @@ cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstal <+> ppr (mkUnit pkg)) | otherwise = empty - in pp_suggestions ms $$ mayShowLocations fps + in pp_suggestions ms $$ may_show_locations fps NotAModule -> text "It is not a module in the current program, or in any known package." CouldntFindInFiles fps -> vcat (map text fps) MultiplePackages mods @@ -254,7 +254,7 @@ cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstal vcat (map pkg_hidden pkg_hiddens) $$ vcat (map mod_hidden mod_hiddens) $$ vcat (map unusable unusables) $$ - mayShowLocations files + may_show_locations files where pprMod (m, o) = text "it is bound as" <+> ppr m <+> text "by" <+> pprOrigin m o @@ -274,7 +274,7 @@ cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstal <+> quotes (ppr uid) --FIXME: we don't really want to show the unit id here we should -- show the source package id or installed package id if it's ambiguous - <> dot $$ pkg_hidden_hint uif + <> dot $$ maybe empty pkg_hidden_hint uif mod_hidden pkg = ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -4,21 +4,29 @@ module GHCi.UI.Exception(printGhciException) where import GHC.Prelude -import GHC.Utils.Logger -import Control.Monad.IO.Class -import GHC.Driver.Session -import GHC.Types.SourceError + +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Errors import GHC.Driver.Errors.Types -import GHC.Types.Error +import GHC.Driver.Session + +import GHC.Iface.Errors.Ppr import GHC.Iface.Errors.Types -import GHC.Tc.Errors.Types + import GHC.Tc.Errors.Ppr -import GHC.Iface.Errors.Ppr -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Errors -import GHC.Utils.Outputable +import GHC.Tc.Errors.Types + +import GHC.Types.Error +import GHC.Types.SourceError + import GHC.Unit.State +import GHC.Utils.Logger +import GHC.Utils.Outputable + +import Control.Monad.IO.Class + + -- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting -- for some error messages. printGhciException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f936f1486533581027073040256693477766703b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f936f1486533581027073040256693477766703b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 08:42:01 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Wed, 03 May 2023 04:42:01 -0400 Subject: [Git][ghc/ghc][wip/t22884] 43 commits: JS: fix thread-related primops Message-ID: <64521e591b64b_3c911519fcfaa8222081@gitlab.mail> Matthew Pickering pushed to branch wip/t22884 at Glasgow Haskell Compiler / GHC Commits: d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 704d0cf5 by Matthew Pickering at 2023-05-03T09:35:28+01:00 Introduce GHCiMessage to wrap GhcMessage By introducing a wrapped message type we can control how certain messages are printed in GHCi (to add extra information for example) - - - - - 829ef895 by Matthew Pickering at 2023-05-03T09:35:28+01:00 Abstract cantFindError and turn Opt_BuildingCabal into a print-time option * cantFindError is abstracted so that the parts which mention specific things about ghc/ghci are parameters. The intention being that GHC/GHCi can specify the right values to put here but otherwise display the same error message. * The BuildingCabalPackage argument from GenericMissing is removed and turned into a print-time option. The reason for the error is not dependent on whether `-fbuilding-cabal-package` is passed, so we don't want to store that in the error message. - - - - - b7305383 by Matthew Pickering at 2023-05-03T09:40:32+01:00 error messages: Don't display ghci specific hints for missing packages I am unsure about whether the approach taken here is the best of most maintainable solution. I put it up here for review and comment. Fixes #22884 - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Config/Diagnostic.hs - compiler/GHC/Driver/Make.hs - + compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Unbound.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f936f1486533581027073040256693477766703b...b730538390c7bec8d286b965394fd3b69d4dc606 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f936f1486533581027073040256693477766703b...b730538390c7bec8d286b965394fd3b69d4dc606 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 08:48:20 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Wed, 03 May 2023 04:48:20 -0400 Subject: [Git][ghc/ghc][wip/t22884] error messages: Don't display ghci specific hints for missing packages Message-ID: <64521fd428e3f_3c911519f6773c2225cb@gitlab.mail> Matthew Pickering pushed to branch wip/t22884 at Glasgow Haskell Compiler / GHC Commits: 5ca31f41 by Matthew Pickering at 2023-05-03T09:46:57+01:00 error messages: Don't display ghci specific hints for missing packages Tickets like #22884 suggest that it is confusing that GHC used on the command line can suggest options which only work in GHCi. This ticket uses the error message infrastructure to override certain error messages which displayed GHCi specific information so that this information is only showed when using GHCi. The main annoyance is that we mostly want to display errors in the same way as before, but with some additional information. This means that the error rendering code has to be exported from the Iface/Errors/Ppr.hs module. I am unsure about whether the approach taken here is the best or most maintainable solution. Fixes #22884 - - - - - 23 changed files: - compiler/GHC/Iface/Errors/Ppr.hs - ghc/GHCi/UI/Exception.hs - testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stderr - testsuite/tests/ghc-api/target-contents/TargetContents.stderr - testsuite/tests/ghc-e/should_run/T2636.stderr - testsuite/tests/module/mod1.stderr - testsuite/tests/module/mod2.stderr - + testsuite/tests/package/T22884.hs - + testsuite/tests/package/T22884.stderr - + testsuite/tests/package/T22884_interactive.script - + testsuite/tests/package/T22884_interactive.stderr - testsuite/tests/package/T4806.stderr - testsuite/tests/package/T4806a.stderr - testsuite/tests/package/all.T - testsuite/tests/package/package01e.stderr - testsuite/tests/package/package06e.stderr - testsuite/tests/package/package07e.stderr - testsuite/tests/package/package08e.stderr - testsuite/tests/perf/compiler/parsing001.stderr - testsuite/tests/plugins/T11244.stderr - testsuite/tests/plugins/plugins03.stderr - testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr - testsuite/tests/typecheck/should_fail/tcfail082.stderr Changes: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -19,6 +19,11 @@ module GHC.Iface.Errors.Ppr , missingInterfaceErrorReason , missingInterfaceErrorDiagnostic , readInterfaceErrorDiagnostic + + , lookingForHerald + , cantFindErrorX + , mayShowLocations + , pkgHiddenHint ) where @@ -130,34 +135,34 @@ cantFindError :: IfaceMessageOpts -> FindingModuleOrInterface -> CantFindInstalled -> SDoc -cantFindError opts = cantFindErrorX (pkg_hidden_hint (ifaceBuildingCabalPackage opts)) (mayShowLocations (ifaceShowTriedFiles opts)) - where - pkg_hidden_hint using_cabal (Just pkg) - | using_cabal == YesBuildingCabalPackage - = text "Perhaps you need to add" <+> - quotes (ppr (unitPackageName pkg)) <+> - text "to the build-depends in your .cabal file." - -- MP: This is ghci specific, remove - | otherwise - = text "You can run" <+> - quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> - text "to expose it." $$ - text "(Note: this unloads all the modules in the current scope.)" - pkg_hidden_hint _ Nothing = empty - -mayShowLocations :: Bool -> [FilePath] -> SDoc -mayShowLocations verbose files +cantFindError opts = + cantFindErrorX + (pkgHiddenHint (const empty) (ifaceBuildingCabalPackage opts)) + (mayShowLocations "-v" (ifaceShowTriedFiles opts)) + + +pkgHiddenHint :: (UnitInfo -> SDoc) -> BuildingCabalPackage + -> UnitInfo -> SDoc +pkgHiddenHint _hint YesBuildingCabalPackage pkg + = text "Perhaps you need to add" <+> + quotes (ppr (unitPackageName pkg)) <+> + text "to the build-depends in your .cabal file." +pkgHiddenHint hint _not_cabal pkg + = hint pkg + +mayShowLocations :: String -> Bool -> [FilePath] -> SDoc +mayShowLocations option verbose files | null files = empty | not verbose = - text "Use -v (or `:set -v` in ghci) " <> + text "Use" <+> text option <+> text "to see a list of the files searched for." | otherwise = hang (text "Locations searched:") 2 $ vcat (map text files) -- | General version of cantFindError which has some holes which allow GHC/GHCi to display slightly different -- error messages. -cantFindErrorX :: (Maybe UnitInfo -> SDoc) -> ([FilePath] -> SDoc) -> FindingModuleOrInterface -> CantFindInstalled -> SDoc -cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstalled mod_name cfir) = +cantFindErrorX :: (UnitInfo -> SDoc) -> ([FilePath] -> SDoc) -> FindingModuleOrInterface -> CantFindInstalled -> SDoc +cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInstalled mod_name cfir) = let ambig = isAmbiguousInstalledReason cfir find_or_load = isLoadOrFindReason cfir ppr_what = prettyCantFindWhat find_or_load mod_or_interface ambig @@ -185,11 +190,11 @@ cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstal text "There are files missing in the " <> quotes (ppr pkg) <+> text "package," $$ text "try running 'ghc-pkg check'." $$ - mayShowLocations files + may_show_locations files MissingPackageWayFiles build pkg files -> text "Perhaps you haven't installed the " <> text build <+> text "libraries for package " <> quotes (ppr pkg) <> char '?' $$ - mayShowLocations files + may_show_locations files ModuleSuggestion ms fps -> let pp_suggestions :: [ModuleSuggestion] -> SDoc @@ -231,7 +236,7 @@ cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstal <+> ppr (mkUnit pkg)) | otherwise = empty - in pp_suggestions ms $$ mayShowLocations fps + in pp_suggestions ms $$ may_show_locations fps NotAModule -> text "It is not a module in the current program, or in any known package." CouldntFindInFiles fps -> vcat (map text fps) MultiplePackages mods @@ -249,7 +254,7 @@ cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstal vcat (map pkg_hidden pkg_hiddens) $$ vcat (map mod_hidden mod_hiddens) $$ vcat (map unusable unusables) $$ - mayShowLocations files + may_show_locations files where pprMod (m, o) = text "it is bound as" <+> ppr m <+> text "by" <+> pprOrigin m o @@ -269,7 +274,7 @@ cantFindErrorX pkg_hidden_hint mayShowLocations mod_or_interface (CantFindInstal <+> quotes (ppr uid) --FIXME: we don't really want to show the unit id here we should -- show the source package id or installed package id if it's ambiguous - <> dot $$ pkg_hidden_hint uif + <> dot $$ maybe empty pkg_hidden_hint uif mod_hidden pkg = @@ -286,17 +291,17 @@ interfaceErrorDiagnostic opts = \ case Can'tFindNameInInterface name relevant_tyThings -> missingDeclInInterface name relevant_tyThings Can'tFindInterface err looking_for -> + hangNotEmpty (lookingForHerald looking_for) 2 (missingInterfaceErrorDiagnostic opts err) + +lookingForHerald :: InterfaceLookingFor -> SDoc +lookingForHerald looking_for = case looking_for of - LookingForName {} -> - missingInterfaceErrorDiagnostic opts err - LookingForModule {} -> - missingInterfaceErrorDiagnostic opts err + LookingForName {} -> empty + LookingForModule {} -> empty LookingForHiBoot mod -> - hang (text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon) - 2 (missingInterfaceErrorDiagnostic opts err) + text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon LookingForSig sig -> - hang (text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon) - 2 (missingInterfaceErrorDiagnostic opts err) + text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc readInterfaceErrorDiagnostic = \ case ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -4,14 +4,28 @@ module GHCi.UI.Exception(printGhciException) where import GHC.Prelude -import GHC.Utils.Logger -import Control.Monad.IO.Class -import GHC.Driver.Session -import GHC.Types.SourceError -import GHC.Driver.Errors.Types -import GHC.Types.Error + import GHC.Driver.Config.Diagnostic import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Session + +import GHC.Iface.Errors.Ppr +import GHC.Iface.Errors.Types + +import GHC.Tc.Errors.Ppr +import GHC.Tc.Errors.Types + +import GHC.Types.Error +import GHC.Types.SourceError + +import GHC.Unit.State + +import GHC.Utils.Logger +import GHC.Utils.Outputable + +import Control.Monad.IO.Class + -- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting -- for some error messages. @@ -24,14 +38,14 @@ printGhciException err = do liftIO $ printMessages logger print_config diag_opts (GHCiMessage <$> (srcErrorMessages err)) -newtype GHCiMessage = GHCiMessage { getGhciMessage :: GhcMessage } +newtype GHCiMessage = GHCiMessage { _getGhciMessage :: GhcMessage } instance Diagnostic GHCiMessage where type DiagnosticOpts GHCiMessage = DiagnosticOpts GhcMessage defaultDiagnosticOpts = defaultDiagnosticOpts @GhcMessage - diagnosticMessage opts (GHCiMessage msg) = diagnosticMessage opts msg + diagnosticMessage opts (GHCiMessage msg) = ghciDiagnosticMessage opts msg diagnosticReason (GHCiMessage msg) = diagnosticReason msg @@ -39,4 +53,38 @@ instance Diagnostic GHCiMessage where diagnosticCode (GHCiMessage msg) = diagnosticCode msg +-- Modifications to error messages which we want to display in GHCi +ghciDiagnosticMessage :: GhcMessageOpts -> GhcMessage -> DecoratedSDoc +ghciDiagnosticMessage ghc_opts msg = + case msg of + GhcTcRnMessage (TcRnInterfaceError err) -> + case ghciInterfaceError err of + Just sdoc -> mkSimpleDecorated sdoc + Nothing -> diagnosticMessage ghc_opts msg + GhcDriverMessage (DriverInterfaceError err) -> + case ghciInterfaceError err of + Just sdoc -> mkSimpleDecorated sdoc + Nothing -> diagnosticMessage ghc_opts msg + _ -> diagnosticMessage ghc_opts msg + where + opts = tcOptsIfaceOpts (tcMessageOpts ghc_opts) + + ghciInterfaceError (Can'tFindInterface err looking_for) = + hangNotEmpty (lookingForHerald looking_for) 2 <$> ghciMissingInterfaceErrorDiagnostic err + ghciInterfaceError _ = Nothing + + ghciMissingInterfaceErrorDiagnostic reason = + case reason of + CantFindErr us module_or_interface cfi -> Just (pprWithUnitState us $ cantFindErrorX pkg_hidden_hint may_show_locations module_or_interface cfi) + _ -> Nothing + where + + may_show_locations = mayShowLocations ":set -v" (ifaceShowTriedFiles opts) + pkg_hidden_hint = pkgHiddenHint hidden_msg (ifaceBuildingCabalPackage opts) + where + hidden_msg pkg = + text "You can run" <+> + quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> + text "to expose it." $$ + text "(Note: this unloads all the modules in the current scope.)" ===================================== testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stderr ===================================== @@ -2,4 +2,4 @@ module-visibility-import/MV.hs:5:1: error: [GHC-87110] Could not load module ‘MV2’. it is a hidden module in the package ‘mv’ - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/ghc-api/target-contents/TargetContents.stderr ===================================== @@ -18,7 +18,7 @@ B.hs:3:5: error: [GHC-88464] Variable not in scope: z A.hs:3:1: error: [GHC-87110] Could not find module ‘B’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. == Dep_DM_AB == Dep_Error_DM_AB @@ -27,7 +27,7 @@ B.hs:3:5: error: [GHC-88464] Variable not in scope: z A.hs:3:1: error: [GHC-87110] Could not find module ‘B’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. == Dep_MD_AB == Dep_Error_MD_AB ===================================== testsuite/tests/ghc-e/should_run/T2636.stderr ===================================== @@ -1,4 +1,4 @@ T2636.hs:1:1: error: [GHC-87110] Could not find module ‘MissingModule’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/module/mod1.stderr ===================================== @@ -1,4 +1,4 @@ mod1.hs:3:1: error: [GHC-87110] Could not find module ‘N’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/module/mod2.stderr ===================================== @@ -1,4 +1,4 @@ mod2.hs:3:1: error: [GHC-87110] Could not find module ‘N’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/package/T22884.hs ===================================== @@ -0,0 +1,3 @@ +module T22884 where + +import Data.Text ===================================== testsuite/tests/package/T22884.stderr ===================================== @@ -0,0 +1,5 @@ + +T22884.hs:3:1: error: [GHC-87110] + Could not load module ‘Data.Text’. + It is a member of the hidden package ‘text-2.0.2’. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/package/T22884_interactive.script ===================================== @@ -0,0 +1,3 @@ +:set -hide-all-packages + +import Data.Text ===================================== testsuite/tests/package/T22884_interactive.stderr ===================================== @@ -0,0 +1,6 @@ + +: error: [GHC-87110] + Could not load module ‘Data.Text’. + It is a member of the hidden package ‘text-2.0.2’. + You can run ‘:set -package text’ to expose it. + (Note: this unloads all the modules in the current scope.) ===================================== testsuite/tests/package/T4806.stderr ===================================== @@ -3,4 +3,4 @@ T4806.hs:1:1: error: [GHC-87110] Could not load module ‘Data.Map’. It is a member of the package ‘containers-0.6.7’ which is ignored due to an -ignore-package flag - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/package/T4806a.stderr ===================================== @@ -4,4 +4,4 @@ T4806a.hs:1:1: error: [GHC-87110] It is a member of the package ‘containers-0.6.7’ which is unusable because the -ignore-package flag was used to ignore at least one of its dependencies: deepseq-1.4.8.1 template-haskell-2.20.0.0 - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/package/all.T ===================================== @@ -20,3 +20,5 @@ test('package10', normal, compile, ['-hide-all-packages -package "ghc (GHC test('T4806', normalise_version('containers'), compile_fail, ['-ignore-package containers']) test('T4806a', normalise_version('deepseq', 'containers'), compile_fail, ['-ignore-package deepseq']) +test('T22884', normalise_version('text'), compile_fail, ['-hide-package text']) +test('T22884_interactive', normalise_version('text'), ghci_script, ['T22884_interactive.script']) ===================================== testsuite/tests/package/package01e.stderr ===================================== @@ -2,13 +2,9 @@ package01e.hs:2:1: error: [GHC-87110] Could not load module ‘Data.Map’. It is a member of the hidden package ‘containers-0.6.7’. - You can run ‘:set -package containers’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. package01e.hs:3:1: error: [GHC-87110] Could not load module ‘Data.IntMap’. It is a member of the hidden package ‘containers-0.6.7’. - You can run ‘:set -package containers’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/package/package06e.stderr ===================================== @@ -2,13 +2,9 @@ package06e.hs:2:1: error: [GHC-87110] Could not load module ‘GHC.Hs.Type’. It is a member of the hidden package ‘ghc-9.7’. - You can run ‘:set -package ghc’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. package06e.hs:3:1: error: [GHC-87110] Could not load module ‘GHC.Types.Unique.FM’. It is a member of the hidden package ‘ghc-9.7’. - You can run ‘:set -package ghc’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/package/package07e.stderr ===================================== @@ -5,25 +5,19 @@ package07e.hs:2:1: error: [GHC-61948] GHC.Hs.Type (needs flag -package-id ghc-9.7) GHC.Tc.Types (needs flag -package-id ghc-9.7) GHC.Hs.Syn.Type (needs flag -package-id ghc-9.7) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. package07e.hs:3:1: error: [GHC-87110] Could not load module ‘GHC.Hs.Type’. It is a member of the hidden package ‘ghc-9.7’. - You can run ‘:set -package ghc’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. package07e.hs:4:1: error: [GHC-87110] Could not load module ‘GHC.Hs.Utils’. It is a member of the hidden package ‘ghc-9.7’. - You can run ‘:set -package ghc’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. package07e.hs:5:1: error: [GHC-87110] Could not load module ‘GHC.Types.Unique.FM’. It is a member of the hidden package ‘ghc-9.7’. - You can run ‘:set -package ghc’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/package/package08e.stderr ===================================== @@ -5,25 +5,19 @@ package08e.hs:2:1: error: [GHC-61948] GHC.Hs.Type (needs flag -package-id ghc-9.7) GHC.Tc.Types (needs flag -package-id ghc-9.7) GHC.Hs.Syn.Type (needs flag -package-id ghc-9.7) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. package08e.hs:3:1: error: [GHC-87110] Could not load module ‘GHC.Hs.Type’. It is a member of the hidden package ‘ghc-9.7’. - You can run ‘:set -package ghc’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. package08e.hs:4:1: error: [GHC-87110] Could not load module ‘GHC.Hs.Utils’. It is a member of the hidden package ‘ghc-9.7’. - You can run ‘:set -package ghc’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. package08e.hs:5:1: error: [GHC-87110] Could not load module ‘GHC.Types.Unique.FM’. It is a member of the hidden package ‘ghc-9.7’. - You can run ‘:set -package ghc’ to expose it. - (Note: this unloads all the modules in the current scope.) - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/perf/compiler/parsing001.stderr ===================================== @@ -1,4 +1,4 @@ parsing001.hs:3:1: error: [GHC-87110] Could not find module ‘Wibble’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/plugins/T11244.stderr ===================================== @@ -1,5 +1,3 @@ : Could not load module ‘RuleDefiningPlugin’. It is a member of the hidden package ‘rule-defining-plugin-0.1’. -You can run ‘:set -package rule-defining-plugin’ to expose it. -(Note: this unloads all the modules in the current scope.) -Use -v (or `:set -v` in ghci) to see a list of the files searched for. +Use -v to see a list of the files searched for. ===================================== testsuite/tests/plugins/plugins03.stderr ===================================== @@ -1,2 +1,2 @@ : Could not find module ‘Simple.NonExistentPlugin’. -Use -v (or `:set -v` in ghci) to see a list of the files searched for. +Use -v to see a list of the files searched for. ===================================== testsuite/tests/safeHaskell/safeLanguage/SafeLang07.stderr ===================================== @@ -4,4 +4,4 @@ SafeLang07.hs:2:14: warning: SafeLang07.hs:15:1: error: [GHC-87110] Could not find module ‘SafeLang07_A’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. ===================================== testsuite/tests/typecheck/should_fail/tcfail082.stderr ===================================== @@ -1,12 +1,12 @@ tcfail082.hs:2:1: error: [GHC-87110] Could not find module ‘Data82’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. tcfail082.hs:3:1: error: [GHC-87110] Could not find module ‘Inst82_1’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. tcfail082.hs:4:1: error: [GHC-87110] Could not find module ‘Inst82_2’. - Use -v (or `:set -v` in ghci) to see a list of the files searched for. + Use -v to see a list of the files searched for. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5ca31f4164adeb6393aa249d633f548bf775399f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5ca31f4164adeb6393aa249d633f548bf775399f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 08:56:24 2023 From: gitlab at gitlab.haskell.org (Sylvain Henry (@hsyl20)) Date: Wed, 03 May 2023 04:56:24 -0400 Subject: [Git][ghc/ghc][wip/js-boundsCheck] Fix remaining issues with bound checking (#23123) Message-ID: <645221b82dd4c_3c911519fceb58228691@gitlab.mail> Sylvain Henry pushed to branch wip/js-boundsCheck at Glasgow Haskell Compiler / GHC Commits: eed582b5 by Sylvain Henry at 2023-05-03T10:55:20+02:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 9 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,219 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsCheckedRangeLen bound a1 o1 n - . boundsCheckedRangeLen bound a2 o2 n + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsCheckedRangeLen bound a1 o1 n - . boundsCheckedRangeLen bound a2 o2 n - . checkOverlapByteArray bound a1 o1 a2 o2 n - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsCheckedRangeLen bound a o n $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -757,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -918,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1032,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsCheckedLen bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsCheckedLen bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsCheckedLen bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsCheckedLen bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsCheckedLen bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1368,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1392,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1407,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1417,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1432,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1445,73 +1387,151 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked' +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound :: JExpr -- ^ Max index expression -> Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Index -> JStat -- ^ Result -> JStat -boundsChecked' _ False _ r = r -boundsChecked' max_index True i r = - ifS ((i .>=. zero_) .&&. (i .<. max_index)) r $ - returnS (app "h$exitProcess" [Int 134]) +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] -- | Bounds checking using ".length" property (Arrays) -boundsChecked +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index + -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -boundsChecked do_check arr = boundsChecked' (arr .^ "length") do_check +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) -- | Bounds checking using ".len" property (ByteArrays) -boundsCheckedLen +bnd_ba :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index -> JStat -- ^ Result -> JStat -boundsCheckedLen do_check arr = boundsChecked' (arr .^ "len") do_check +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r -- | Bounds checking on a range and using ".len" property (ByteArrays) -- -- Empty ranges trivially pass the check -boundsCheckedRangeLen +bnd_ba_range :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -boundsCheckedRangeLen False _ _ _ r = r -boundsCheckedRangeLen True xs i n r = +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ - ifS (n .===. zero_) -- We can always fill zero elements, even if it seems out-of-bounds + -- Empty ranges trivially pass the check + ifS (n .===. zero_) r - (boundsCheckedLen True xs (Add i (Sub n 1)) (boundsCheckedLen True xs i r)) + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) checkOverlapByteArray :: Bool -- ^ Should we do bounds checking? @@ -1522,20 +1542,18 @@ checkOverlapByteArray -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray False _ _ _ _ _ r = r checkOverlapByteArray True a1 o1 a2 o2 n r = ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) -byteIndex16 :: JExpr -> JExpr -byteIndex16 i = Add 1 (Mul 2 i) - -byteIndex32 :: JExpr -> JExpr -byteIndex32 i = Add 3 (Mul 4 i) - -byteIndex64 :: JExpr -> JExpr -byteIndex64 i = Add 7 (Mul 8 i) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; return true; } ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(21142), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eed582b504a14b307bef635b25a10e2ce2c9110e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eed582b504a14b307bef635b25a10e2ce2c9110e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 09:25:14 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Wed, 03 May 2023 05:25:14 -0400 Subject: [Git][ghc/ghc][wip/unitidset] 27 commits: testsuite/T20137: Avoid impl.-defined behavior Message-ID: <6452287aeb4e4_3c911519f6773c2321ed@gitlab.mail> Josh Meredith pushed to branch wip/unitidset at Glasgow Haskell Compiler / GHC Commits: 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 4fd0540c by Josh Meredith at 2023-05-03T09:23:46+00:00 Refactor `Set UnitId` to `UniqDSet UnitId` (#23335) - - - - - 30 changed files: - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Hs.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Rename/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e398305cf56890538eedaa0da43d3d8f98c5b197...4fd0540ce926b7e41e9378cb54b0545ce6665a07 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e398305cf56890538eedaa0da43d3d8f98c5b197...4fd0540ce926b7e41e9378cb54b0545ce6665a07 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 10:26:11 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Wed, 03 May 2023 06:26:11 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <645236c3550ed_3c91151cf4c2b82425cb@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 721877cf by Josh Meredith at 2023-05-03T10:25:58+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 6 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform ( identsS @@ -22,7 +23,6 @@ module GHC.JS.Transform , composOpM_ , composOpFold , satJExpr - , satJStat ) where @@ -33,7 +33,6 @@ import GHC.JS.Unsat.Syntax import Data.Functor.Identity import Control.Monad -import Control.Arrow ((***)) import GHC.Data.FastString import GHC.Utils.Monad.State.Strict @@ -200,66 +199,61 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v - +jsSaturate :: Maybe FastString -> JStat -> Sat.JStat +jsSaturate str x = evalState (jsSaturateS x) (newIdentSupply str) + +jsSaturateS :: JStat -> State [Ident] Sat.JStat +jsSaturateS = \case + DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs + ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e + IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e + WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e + ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body + SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct + <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps + <*> jsSaturateS def + TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f + BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs + ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand + UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand + AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> jsSaturateE rhs + LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt + BreakStat m_l -> return $ Sat.BreakStat $! m_l + ContinueStat m_l -> return $ Sat.ContinueStat $! m_l + UnsatBlock us -> jsSaturateS =<< runIdentSupply us + +jsSaturateE :: JExpr -> State [Ident] Sat.JExpr +jsSaturateE = \case + ValExpr v -> Sat.ValExpr <$> jsSaturateV v + SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i + IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i + InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r + UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r + IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e + ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands + UnsatExpr us -> jsSaturateE =<< runIdentSupply us + +jsSaturateV :: JVal -> State [Ident] Sat.JVal +jsSaturateV = \case + JVar i -> return $ Sat.JVar i + JList xs -> Sat.JList <$> mapM jsSaturateE xs + JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) + JInt i -> return $ Sat.JInt i + JStr s -> return $ Sat.JStr s + JRegEx f -> return $ Sat.JRegEx f + JHash m -> return $ Sat.JHash (satJExpr <$> m) + JFunc args body -> Sat.JFunc args <$> jsSaturateS body + UnsatVal us -> jsSaturateV =<< runIdentSupply us + -------------------------------------------------------------------------------- -- Translation -- -- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing - - -- This is an Applicative but we can't use it because no type variables :( - witness :: JStat -> Sat.JStat - witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) - witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) - witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) - witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) - witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i - (satJExpr iter) - (witness body) - witness (SwitchStat struct ps def) = Sat.SwitchStat - (satJExpr struct) - (map (satJExpr *** witness) ps) - (witness def) - witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) - witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs - witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) - witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) - witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) - witness (BreakStat Nothing) = Sat.BreakStat Nothing - witness (BreakStat (Just l)) = Sat.BreakStat $! Just l - witness (ContinueStat Nothing) = Sat.ContinueStat Nothing - witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l - witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" - satJExpr :: JExpr -> Sat.JExpr -satJExpr = go - where - go (ValExpr v) = Sat.ValExpr (satJVal v) - go (SelExpr obj i) = Sat.SelExpr (satJExpr obj) i - go (IdxExpr o i) = Sat.IdxExpr (satJExpr o) (satJExpr i) - go (InfixExpr op l r) = Sat.InfixExpr (satJOp op) (satJExpr l) (satJExpr r) - go (UOpExpr op r) = Sat.UOpExpr (satJUOp op) (satJExpr r) - go (IfExpr c t e) = Sat.IfExpr (satJExpr c) (satJExpr t) (satJExpr e) - go (ApplExpr rator rands) = Sat.ApplExpr (satJExpr rator) (satJExpr <$> rands) - go UnsatExpr{} = error "satJExpr: discovered an Unsat...impossibly" +satJExpr x = evalState (jsSaturateE x) (newIdentSupply $ error "satJExpr: discovered an Unsat...impossibly") satJOp :: JOp -> Sat.Op satJOp = go @@ -305,15 +299,3 @@ satJUOp = go go PreDecOp = Sat.PreDecOp go PostDecOp = Sat.PostDecOp -satJVal :: JVal -> Sat.JVal -satJVal = go - where - go (JVar i) = Sat.JVar i - go (JList xs) = Sat.JList (satJExpr <$> xs) - go (JDouble d) = Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) - go (JInt i) = Sat.JInt i - go (JStr f) = Sat.JStr f - go (JRegEx f) = Sat.JRegEx f - go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) - go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a +saturateFFI :: Int -> JStat -> Sat.JStat saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) @@ -180,4 +181,4 @@ globalOccs jst = do let g = GlobalOcc i gid 1 in go (addToUFM_C inc gids i g) is - pure $ go emptyUFM (identsS $ satJStat jst) + pure $ go emptyUFM (identsS jst) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat +rtsDecls :: Sat.JStat rtsDecls = jsSaturate (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread @@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat +rts :: StgToJSConfig -> Sat.JStat rts = jsSaturate (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/721877cffd0db35e95f1dd93a176baa35232c5d3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/721877cffd0db35e95f1dd93a176baa35232c5d3 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 11:01:09 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Wed, 03 May 2023 07:01:09 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <64523ef5755fa_3c91151e33e3e8253084@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 5c79cd4d by Josh Meredith at 2023-05-03T11:00:57+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 6 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform ( identsS @@ -22,7 +23,6 @@ module GHC.JS.Transform , composOpM_ , composOpFold , satJExpr - , satJStat ) where @@ -33,7 +33,6 @@ import GHC.JS.Unsat.Syntax import Data.Functor.Identity import Control.Monad -import Control.Arrow ((***)) import GHC.Data.FastString import GHC.Utils.Monad.State.Strict @@ -200,18 +199,51 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v +jsSaturate :: Maybe FastString -> JStat -> Sat.JStat +jsSaturate str x = evalState (jsSaturateS x) (newIdentSupply str) + +jsSaturateS :: JStat -> State [Ident] Sat.JStat +jsSaturateS = \case + DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs + ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e + IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e + WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e + ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body + SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct + <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps + <*> jsSaturateS def + TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f + BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs + ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand + UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand + AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> jsSaturateE rhs + LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt + BreakStat m_l -> return $ Sat.BreakStat $! m_l + ContinueStat m_l -> return $ Sat.ContinueStat $! m_l + UnsatBlock us -> jsSaturateS =<< runIdentSupply us + +jsSaturateE :: JExpr -> State [Ident] Sat.JExpr +jsSaturateE = \case + ValExpr v -> Sat.ValExpr <$> jsSaturateV v + SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i + IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i + InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r + UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r + IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e + ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands + UnsatExpr us -> jsSaturateE =<< runIdentSupply us + +jsSaturateV :: JVal -> State [Ident] Sat.JVal +jsSaturateV = \case + JVar i -> return $ Sat.JVar i + JList xs -> Sat.JList <$> mapM jsSaturateE xs + JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) + JInt i -> return $ Sat.JInt i + JStr s -> return $ Sat.JStr s + JRegEx f -> return $ Sat.JRegEx f + JHash m -> return $ Sat.JHash (satJExpr <$> m) + JFunc args body -> Sat.JFunc args <$> jsSaturateS body + UnsatVal us -> jsSaturateV =<< runIdentSupply us -------------------------------------------------------------------------------- @@ -219,47 +251,9 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) -- -- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing - - -- This is an Applicative but we can't use it because no type variables :( - witness :: JStat -> Sat.JStat - witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) - witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) - witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) - witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) - witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i - (satJExpr iter) - (witness body) - witness (SwitchStat struct ps def) = Sat.SwitchStat - (satJExpr struct) - (map (satJExpr *** witness) ps) - (witness def) - witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) - witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs - witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) - witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) - witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) - witness (BreakStat Nothing) = Sat.BreakStat Nothing - witness (BreakStat (Just l)) = Sat.BreakStat $! Just l - witness (ContinueStat Nothing) = Sat.ContinueStat Nothing - witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l - witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" - satJExpr :: JExpr -> Sat.JExpr -satJExpr = go - where - go (ValExpr v) = Sat.ValExpr (satJVal v) - go (SelExpr obj i) = Sat.SelExpr (satJExpr obj) i - go (IdxExpr o i) = Sat.IdxExpr (satJExpr o) (satJExpr i) - go (InfixExpr op l r) = Sat.InfixExpr (satJOp op) (satJExpr l) (satJExpr r) - go (UOpExpr op r) = Sat.UOpExpr (satJUOp op) (satJExpr r) - go (IfExpr c t e) = Sat.IfExpr (satJExpr c) (satJExpr t) (satJExpr e) - go (ApplExpr rator rands) = Sat.ApplExpr (satJExpr rator) (satJExpr <$> rands) - go UnsatExpr{} = error "satJExpr: discovered an Unsat...impossibly" +satJExpr x = evalState (jsSaturateE x) (newIdentSupply $ error "satJExpr: discovered an Unsat...impossibly") satJOp :: JOp -> Sat.Op satJOp = go @@ -305,15 +299,3 @@ satJUOp = go go PreDecOp = Sat.PreDecOp go PostDecOp = Sat.PostDecOp -satJVal :: JVal -> Sat.JVal -satJVal = go - where - go (JVar i) = Sat.JVar i - go (JList xs) = Sat.JList (satJExpr <$> xs) - go (JDouble d) = Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) - go (JInt i) = Sat.JInt i - go (JStr f) = Sat.JStr f - go (JRegEx f) = Sat.JRegEx f - go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) - go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a +saturateFFI :: Int -> JStat -> Sat.JStat saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) @@ -180,4 +181,4 @@ globalOccs jst = do let g = GlobalOcc i gid 1 in go (addToUFM_C inc gids i g) is - pure $ go emptyUFM (identsS $ satJStat jst) + pure $ go emptyUFM (identsS jst) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat +rtsDecls :: Sat.JStat rtsDecls = jsSaturate (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread @@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat +rts :: StgToJSConfig -> Sat.JStat rts = jsSaturate (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c79cd4d57bdf27c6ab98f201fe65be2181266f5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c79cd4d57bdf27c6ab98f201fe65be2181266f5 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 11:33:42 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Wed, 03 May 2023 07:33:42 -0400 Subject: [Git][ghc/ghc][wip/supersven/riscv-increase-CI-happiness] Fix compiler warning about importing GHC.Utils.Panic.Plain in CodeGen.Platform.h Message-ID: <6452469697f50_3c91151dfe08cc265974@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv-increase-CI-happiness at Glasgow Haskell Compiler / GHC Commits: c5024bcb by Sven Tennie at 2023-05-03T11:32:39+00:00 Fix compiler warning about importing GHC.Utils.Panic.Plain in CodeGen.Platform.h - - - - - 1 changed file: - compiler/CodeGen.Platform.h Changes: ===================================== compiler/CodeGen.Platform.h ===================================== @@ -1,7 +1,8 @@ import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ - || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64)) + || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \ + || defined(MACHREGS_riscv64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5024bcbe41c5cab6429185fa4d65c67f87b8aa1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5024bcbe41c5cab6429185fa4d65c67f87b8aa1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 11:34:14 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Wed, 03 May 2023 07:34:14 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <645246b6e2684_3c91151e147bd42662f0@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 2f81fe5a by Josh Meredith at 2023-05-03T11:34:04+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 6 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform ( identsS @@ -22,7 +23,6 @@ module GHC.JS.Transform , composOpM_ , composOpFold , satJExpr - , satJStat ) where @@ -33,11 +33,12 @@ import GHC.JS.Unsat.Syntax import Data.Functor.Identity import Control.Monad -import Control.Arrow ((***)) +import Data.List (sortBy) import GHC.Data.FastString import GHC.Utils.Monad.State.Strict import GHC.Types.Unique.Map +import GHC.Types.Unique.FM {-# INLINE identsS #-} @@ -200,18 +201,53 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v +jsSaturate :: Maybe FastString -> JStat -> Sat.JStat +jsSaturate str x = evalState (jsSaturateS x) (newIdentSupply str) + +jsSaturateS :: JStat -> State [Ident] Sat.JStat +jsSaturateS = \case + DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs + ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e + IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e + WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e + ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body + SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct + <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps + <*> jsSaturateS def + TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f + BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs + ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand + UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand + AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> jsSaturateE rhs + LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt + BreakStat m_l -> return $ Sat.BreakStat $! m_l + ContinueStat m_l -> return $ Sat.ContinueStat $! m_l + UnsatBlock us -> jsSaturateS =<< runIdentSupply us + +jsSaturateE :: JExpr -> State [Ident] Sat.JExpr +jsSaturateE = \case + ValExpr v -> Sat.ValExpr <$> jsSaturateV v + SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i + IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i + InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r + UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r + IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e + ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands + UnsatExpr us -> jsSaturateE =<< runIdentSupply us + +jsSaturateV :: JVal -> State [Ident] Sat.JVal +jsSaturateV = \case + JVar i -> return $ Sat.JVar i + JList xs -> Sat.JList <$> mapM jsSaturateE xs + JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) + JInt i -> return $ Sat.JInt i + JStr s -> return $ Sat.JStr s + JRegEx f -> return $ Sat.JRegEx f + JHash (UniqMap m) -> Sat.JHash . UniqMap . listToUFM + <$> ( mapM (\(f, x) -> jsSaturateE x >>= \x' -> return (f, (f, x')) ) + . sortBy (\x y -> fst x `lexicalCompareFS` fst y) $ nonDetEltsUFM m ) + JFunc args body -> Sat.JFunc args <$> jsSaturateS body + UnsatVal us -> jsSaturateV =<< runIdentSupply us -------------------------------------------------------------------------------- @@ -219,47 +255,9 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) -- -- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing - - -- This is an Applicative but we can't use it because no type variables :( - witness :: JStat -> Sat.JStat - witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) - witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) - witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) - witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) - witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i - (satJExpr iter) - (witness body) - witness (SwitchStat struct ps def) = Sat.SwitchStat - (satJExpr struct) - (map (satJExpr *** witness) ps) - (witness def) - witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) - witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs - witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) - witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) - witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) - witness (BreakStat Nothing) = Sat.BreakStat Nothing - witness (BreakStat (Just l)) = Sat.BreakStat $! Just l - witness (ContinueStat Nothing) = Sat.ContinueStat Nothing - witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l - witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" - satJExpr :: JExpr -> Sat.JExpr -satJExpr = go - where - go (ValExpr v) = Sat.ValExpr (satJVal v) - go (SelExpr obj i) = Sat.SelExpr (satJExpr obj) i - go (IdxExpr o i) = Sat.IdxExpr (satJExpr o) (satJExpr i) - go (InfixExpr op l r) = Sat.InfixExpr (satJOp op) (satJExpr l) (satJExpr r) - go (UOpExpr op r) = Sat.UOpExpr (satJUOp op) (satJExpr r) - go (IfExpr c t e) = Sat.IfExpr (satJExpr c) (satJExpr t) (satJExpr e) - go (ApplExpr rator rands) = Sat.ApplExpr (satJExpr rator) (satJExpr <$> rands) - go UnsatExpr{} = error "satJExpr: discovered an Unsat...impossibly" +satJExpr x = evalState (jsSaturateE x) (newIdentSupply $ error "satJExpr: discovered an Unsat...impossibly") satJOp :: JOp -> Sat.Op satJOp = go @@ -305,15 +303,3 @@ satJUOp = go go PreDecOp = Sat.PreDecOp go PostDecOp = Sat.PostDecOp -satJVal :: JVal -> Sat.JVal -satJVal = go - where - go (JVar i) = Sat.JVar i - go (JList xs) = Sat.JList (satJExpr <$> xs) - go (JDouble d) = Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) - go (JInt i) = Sat.JInt i - go (JStr f) = Sat.JStr f - go (JRegEx f) = Sat.JRegEx f - go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) - go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . jsSaturate (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . jsSaturate (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a +saturateFFI :: Int -> JStat -> Sat.JStat saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) @@ -180,4 +181,4 @@ globalOccs jst = do let g = GlobalOcc i gid 1 in go (addToUFM_C inc gids i g) is - pure $ go emptyUFM (identsS $ satJStat jst) + pure $ go emptyUFM (identsS jst) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat +rtsDecls :: Sat.JStat rtsDecls = jsSaturate (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread @@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat +rts :: StgToJSConfig -> Sat.JStat rts = jsSaturate (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f81fe5a13703ae2d57470238396f5d12bdce0cf -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f81fe5a13703ae2d57470238396f5d12bdce0cf You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 11:52:31 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Wed, 03 May 2023 07:52:31 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/23305 Message-ID: <64524aff41b4a_3c91151dfe08cc2923f1@gitlab.mail> Matthew Pickering pushed new branch wip/23305 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/23305 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 12:20:51 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 03 May 2023 08:20:51 -0400 Subject: [Git][ghc/ghc][wip/T19146] 21 commits: ci: update ci.sh to actually run the entire testsuite for wasm backend Message-ID: <645251a3f3d8b_3c91151e33fbf831088c@gitlab.mail> Ben Gamari pushed to branch wip/T19146 at Glasgow Haskell Compiler / GHC Commits: d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 2b7114a4 by Ben Gamari at 2023-05-03T08:20:41-04:00 rts: Clear block_info when unblocking Otherwise we may end up with dangling pointers which may complicate debugging. - - - - - 98137a48 by Ben Gamari at 2023-05-03T08:20:41-04:00 rts: Weak pointer cleanups Various stylistic cleanups. No functional changes. - - - - - 95d05eb1 by Ben Gamari at 2023-05-03T08:20:41-04:00 rts: Don't force debug output to stderr Previously `+RTS -Dw -l` would emit debug output to the eventlog while `+RTS -l -Dw` would emit it to stderr. This was because the parser for `-D` would unconditionally override the debug output target. Now we instead only do so if no it is currently `TRACE_NONE`. - - - - - 7b8aaee0 by Ben Gamari at 2023-05-03T08:20:41-04:00 rts: Forcibly flush eventlog on barf Previously we would attempt to flush via `endEventLogging` which can easily deadlock, e.g., if `barf` fails during GC. Using `flushEventLog` directly may result in slightly less consistent eventlog output (since we don't take all capabilities before flushing) but avoids deadlocking. - - - - - 604c09d1 by Ben Gamari at 2023-05-03T08:20:45-04:00 rts: Assert that pointers aren't cleared by -DZ This turns many segmentation faults into much easier-to-debug assertion failures by ensuring that LOOKS_LIKE_*_PTR checks recognize bit-patterns produced by `+RTS -DZ` clearing as invalid pointers. This is a bit ad-hoc but this is the debug runtime. - - - - - 981401a9 by Ben Gamari at 2023-05-03T08:20:45-04:00 rts: Don't sanity-check StgTSO.global_link See Note [Avoid dangling global_link pointers]. Fixes #19146. - - - - - a786945f by Ben Gamari at 2023-05-03T08:20:45-04:00 rts: Introduce printGlobalThreads - - - - - 30 changed files: - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Types.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/9.8.1-notes.rst - hadrian/src/Settings/Builders/RunTest.hs - libraries/base/GHC/TypeError.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a117ab986e128d4f409c6be94a0d7f1c6d8912b...a786945f3b976bcb451476f8b1710c4cc313fa4d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a117ab986e128d4f409c6be94a0d7f1c6d8912b...a786945f3b976bcb451476f8b1710c4cc313fa4d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 13:10:04 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 03 May 2023 09:10:04 -0400 Subject: [Git][ghc/ghc][wip/T19146] 2 commits: rts: Don't sanity-check StgTSO.global_link Message-ID: <64525d2ce4c3e_3c91151e119aa43175ec@gitlab.mail> Ben Gamari pushed to branch wip/T19146 at Glasgow Haskell Compiler / GHC Commits: b7999e92 by Ben Gamari at 2023-05-03T09:10:00-04:00 rts: Don't sanity-check StgTSO.global_link See Note [Avoid dangling global_link pointers]. Fixes #19146. - - - - - c69e7e6d by Ben Gamari at 2023-05-03T09:10:00-04:00 rts: Introduce printGlobalThreads - - - - - 3 changed files: - rts/Threads.c - rts/Threads.h - rts/sm/Sanity.c Changes: ===================================== rts/Threads.c ===================================== @@ -1008,6 +1008,20 @@ printAllThreads(void) } } +void +printGlobalThreads(void) +{ + for (uint32_t g = 0; g < RtsFlags.GcFlags.generations; g++) { + debugBelch("\ngen %d\n", g); + for (StgTSO *t = generations[g].threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu)\n", t, t->id); + } + for (StgTSO *t = generations[g].old_threads; t != END_TSO_QUEUE; t = t->global_link) { + debugBelch("thread %p (id=%lu) (old)\n", t, t->id); + } + } +} + // useful from gdb void printThreadQueue(StgTSO *t) ===================================== rts/Threads.h ===================================== @@ -46,6 +46,7 @@ bool performTryPutMVar(Capability *cap, StgMVar *mvar, StgClosure *value); void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); void printAllThreads (void); +void printGlobalThreads(void); void printThreadQueue (StgTSO *t); #endif ===================================== rts/sm/Sanity.c ===================================== @@ -737,6 +737,27 @@ checkSTACK (StgStack *stack) checkStackChunk(sp, stack_end); } +/* + * Note [Sanity-checking global_link] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * TSOs are a bit odd in that they have a global_link pointer field + * which is not scavenged by the GC. This field is used to track the + * generations[_].[old_]threads lists and is ultimately updated by + * MarkWeak.c:tidyThreadList. + + * Typically the fact that this field is not scavenged is fine as all reachable + * TSOs on the heap are guaranteed to be on some generation's thread list and + * therefore will be scavenged by tidyThreadList. However, the sanity checker + * poses a bit of a challenge here as it walks heap blocks directly and + * therefore may encounter TSOs which aren't reachable via the heap. + * For this reason, checkTSO does not check global_link. Instead, we only do + * so in checkGlobalTSOList, which by definition will only look at + * threads which are reachable via a thread list (and therefore must have won + * the forwarding-pointer race). + * + * See #19146. + */ + void checkTSO(StgTSO *tso) { @@ -761,9 +782,11 @@ checkTSO(StgTSO *tso) ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->stackobj)); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && - (tso->global_link == END_TSO_QUEUE || - get_itbl((StgClosure*)tso->global_link)->type == TSO)); + + // This assertion is sadly not viable. See Note [Sanity-checking global_link]. + //ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->global_link) && + // (tso->global_link == END_TSO_QUEUE || + // get_itbl((StgClosure*)tso->global_link)->type == TSO)); if (tso->label) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->label)); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a786945f3b976bcb451476f8b1710c4cc313fa4d...c69e7e6d86c7528d6cb321bb24be52633560acfb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a786945f3b976bcb451476f8b1710c4cc313fa4d...c69e7e6d86c7528d6cb321bb24be52633560acfb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 13:18:42 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Wed, 03 May 2023 09:18:42 -0400 Subject: [Git][ghc/ghc][wip/romes/hardwire-ghc-unit-id] 22 commits: DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) Message-ID: <64525f3235eda_3c91151e119aa4318155@gitlab.mail> Matthew Pickering pushed to branch wip/romes/hardwire-ghc-unit-id at Glasgow Haskell Compiler / GHC Commits: c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - c3a110fc by Matthew Pickering at 2023-05-03T13:18:38+00:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 9ed40a1d by romes at 2023-05-03T13:18:38+00:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 818dfe48 by romes at 2023-05-03T13:18:38+00:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 95ed5487 by romes at 2023-05-03T13:18:38+00:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 4363a87e by Matthew Pickering at 2023-05-03T13:18:38+00:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 30 changed files: - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Names.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/Stg/Lift.hs - compiler/GHC/Stg/Lift/Analysis.hs - compiler/GHC/Stg/Lift/Monad.hs - compiler/GHC/Stg/Lint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e794a65877eee0df6ee9aa7eb04bfbc0a5af67e...4363a87ea1d616f4405ed4e69937161e0b340495 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1e794a65877eee0df6ee9aa7eb04bfbc0a5af67e...4363a87ea1d616f4405ed4e69937161e0b340495 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 15:19:48 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Wed, 03 May 2023 11:19:48 -0400 Subject: [Git][ghc/ghc][wip/unitidset] Refactor `Set UnitId` to `UniqDSet UnitId` (#23335) Message-ID: <64527b943899b_3c91151e2766903556a3@gitlab.mail> Josh Meredith pushed to branch wip/unitidset at Glasgow Haskell Compiler / GHC Commits: df356143 by Josh Meredith at 2023-05-03T15:19:26+00:00 Refactor `Set UnitId` to `UniqDSet UnitId` (#23335) - - - - - 21 changed files: - compiler/GHC.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Types/Unique/DSet.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -395,6 +395,7 @@ import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -418,8 +419,6 @@ import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as S import qualified Data.Sequence as Seq import System.Directory @@ -604,7 +603,7 @@ setSessionDynFlags dflags0 = do logger <- getLogger dflags <- checkNewDynFlags logger dflags0 let all_uids = hsc_all_home_unit_ids hsc_env - case S.toList all_uids of + case uniqDSetToList all_uids of [uid] -> do setUnitDynFlagsNoCheck uid dflags modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags)) @@ -1379,7 +1378,7 @@ data ModuleInfo = ModuleInfo { -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do - if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env + if moduleUnitId mdl `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env then liftIO $ getHomeModuleInfo hsc_env mdl else liftIO $ getPackageModuleInfo hsc_env mdl @@ -1756,7 +1755,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, UnitIdSet) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -56,12 +56,11 @@ import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) +import GHC.Types.Unique.DSet import System.Directory import System.FilePath import System.IO -import Data.Set (Set) -import qualified Data.Set as Set {- ************************************************************************ @@ -84,7 +83,7 @@ codeOutput -> (a -> ForeignStubs) -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with the C compiler - -> Set UnitId -- ^ Dependencies + -> UnitIdSet -- ^ Dependencies -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), @@ -161,11 +160,11 @@ outputC :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a - -> Set UnitId + -> UnitIdSet -> IO a outputC logger dflags filenm cmm_stream unit_deps = withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do - let pkg_names = map unitIdString (Set.toAscList unit_deps) + let pkg_names = map unitIdString (uniqDSetToAscList unit_deps) doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h "#include \"Stg.h\"\n" ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -127,7 +127,7 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env -hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId +hsc_all_home_unit_ids :: HscEnv -> UnitIdSet hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -245,6 +245,7 @@ import GHC.Types.Name.Ppr import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic @@ -274,7 +275,6 @@ import Data.IORef import System.FilePath as FilePath import System.Directory import qualified Data.Set as S -import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) @@ -1457,15 +1457,15 @@ checkSafeImports tcg_env clearDiagnostics -- Check safe imports are correct - safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safePkgs <- mkUniqDSet <$> mapMaybeM checkSafe safeImps safeErrs <- getDiagnostics clearDiagnostics -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyMessages, S.empty) - True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + False -> return (emptyMessages, emptyUniqDSet) + True -> do infPkgs <- mkUniqDSet <$> mapMaybeM checkSafe regImps infErrs <- getDiagnostics clearDiagnostics return (infErrs, infPkgs) @@ -1516,12 +1516,12 @@ checkSafeImports tcg_env checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> + pkgTrustReqs :: DynFlags -> UnitIdSet -> UnitIdSet -> Bool -> ImportAvails pkgTrustReqs dflags req inf infPassed | safeInferOn dflags && not (safeHaskellModeEnabled dflags) && infPassed = emptyImportAvails { - imp_trust_pkgs = req `S.union` inf + imp_trust_pkgs = req `unionUniqDSets` inf } pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe = emptyImportAvails @@ -1540,12 +1540,12 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyMessages errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, UnitIdSet) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l good <- isEmptyMessages `fmap` getDiagnostics clearDiagnostics -- don't want them printed... - let pkgs' | Just p <- self = S.insert p pkgs + let pkgs' | Just p <- self = addOneToUniqDSet pkgs p | otherwise = pkgs return (good, pkgs') @@ -1554,7 +1554,7 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe UnitId, Set UnitId) + -> Hsc (Maybe UnitId, UnitIdSet) hscCheckSafe' m l = do hsc_env <- getHscEnv let home_unit = hsc_home_unit hsc_env @@ -1566,7 +1566,7 @@ hscCheckSafe' m l = do -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) where - isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) + isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, UnitIdSet) isModSafe home_unit m l = do hsc_env <- getHscEnv dflags <- getDynFlags @@ -1648,10 +1648,10 @@ hscCheckSafe' m l = do -- | Check the list of packages are trusted. -checkPkgTrust :: Set UnitId -> Hsc () +checkPkgTrust :: UnitIdSet -> Hsc () checkPkgTrust pkgs = do hsc_env <- getHscEnv - let errors = S.foldr go emptyBag pkgs + let errors = foldr go emptyBag $ uniqDSetToList pkgs state = hsc_units hsc_env go pkg acc | unitIsTrusted $ unsafeLookupUnitId state pkg @@ -1699,7 +1699,7 @@ markUnsafeInfer tcg_env whyUnsafe = do False -> return tcg_env where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = emptyUniqDSet } pprMod = ppr $ moduleName $ tcg_mod tcg_env whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" @@ -2060,7 +2060,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs in NoStubs `appendStubC` ip_init | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] emptyUniqDSet rawCmms return stub_c_exists where ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -107,6 +107,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Types.PkgQual import GHC.Unit @@ -490,7 +491,7 @@ load how_much = loadWithCache noIfaceCache how_much mkBatchMsg :: HscEnv -> Messager mkBatchMsg hsc_env = - if length (hsc_all_home_unit_ids hsc_env) > 1 + if sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 -- This also displays what unit each module is from. then batchMultiMsg else batchMsg @@ -1735,25 +1736,25 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages] +checkHomeUnitsClosed :: UnitEnv -> UnitIdSet -> [(UnitId, UnitId)] -> [DriverMessages] -- Fast path, trivially closed. checkHomeUnitsClosed ue home_id_set home_imp_ids - | Set.size home_id_set == 1 = [] + | sizeUniqDSet home_id_set == 1 = [] | otherwise = - let res = foldMap loop home_imp_ids + let res = foldr (\ids acc -> unionUniqDSets acc $ loop ids) emptyUniqDSet home_imp_ids -- Now check whether everything which transitively depends on a home_unit is actually a home_unit -- These units are the ones which we need to load as home packages but failed to do for some reason, -- it's a bug in the tool invoking GHC. - bad_unit_ids = Set.difference res home_id_set - in if Set.null bad_unit_ids + bad_unit_ids = res `minusUniqDSet` home_id_set + in if isEmptyUniqDSet bad_unit_ids then [] - else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (uniqDSetToAscList bad_unit_ids)] where rootLoc = mkGeneralSrcSpan (fsLit "") -- TODO: This could repeat quite a bit of work but I struggled to write this function. -- Which units transitively depend on a home unit - loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit + loop :: (UnitId, UnitId) -> UnitIdSet -- The units which transitively depend on a home unit loop (from_uid, uid) = let us = ue_findHomeUnitEnv from_uid ue in let um = unitInfoMap (homeUnitEnv_units us) in @@ -1761,20 +1762,21 @@ checkHomeUnitsClosed ue home_id_set home_imp_ids Nothing -> pprPanic "uid not found" (ppr uid) Just ui -> let depends = unitDepends ui - home_depends = Set.fromList depends `Set.intersection` home_id_set - other_depends = Set.fromList depends `Set.difference` home_id_set + home_depends = mkUniqDSet depends `intersectUniqDSets` home_id_set + other_depends = mkUniqDSet depends `minusUniqDSet` home_id_set in -- Case 1: The unit directly depends on a home_id - if not (null home_depends) + if not (isEmptyUniqDSet home_depends) then - let res = foldMap (loop . (from_uid,)) other_depends - in Set.insert uid res + let res :: UnitIdSet + res = foldr (\ide acc -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends + in addOneToUniqDSet res uid -- Case 2: Check the rest of the dependencies, and then see if any of them depended on else - let res = foldMap (loop . (from_uid,)) other_depends + let res = foldr (\ide acc -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends in - if not (Set.null res) - then Set.insert uid res + if not (isEmptyUniqDSet res) + then addOneToUniqDSet res uid else res -- | Update the every ModSummary that is depended on ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -108,6 +108,7 @@ import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.SourceError +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -125,7 +126,7 @@ import Control.Monad import qualified Control.Monad.Catch as MC (handle) import Data.Maybe import Data.Either ( partitionEithers ) -import qualified Data.Set as Set +import Data.List ( sort ) import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp @@ -408,8 +409,8 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt home_mod_infos = eltsHpt hpt -- the packages we depend on - pkg_deps = Set.toList - $ Set.unions + pkg_deps = uniqDSetToList + $ unionManyUniqDSets $ fmap (dep_direct_pkgs . mi_deps . hm_iface) $ home_mod_infos @@ -418,7 +419,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos)) debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) - debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps)) + debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr $ sort pkg_deps)) -- check for the -no-link flag if isNoLink (ghcLink dflags) ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -40,7 +41,6 @@ import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.Set as Set import GHC.Linker.Types import GHC.Unit.Finder @@ -196,7 +196,7 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do mk_mod_usage_info :: UsageConfig -> HomeUnit - -> Set.Set UnitId + -> UnitIdSet -> Module -> ImportedMods -> NameSet @@ -255,7 +255,7 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names -- (need to recompile if its export list changes: export_fprint) mkUsage :: Module -> ModIface -> Maybe Usage mkUsage mod iface - | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids + | not $ toUnitId (moduleUnit mod) `elementOfUniqDSet` home_unit_ids = Just $ UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -504,7 +504,7 @@ loadInterface doc_str mod from -- overlapping instances. ; massertPpr ((isOneShot (ghcMode (hsc_dflags hsc_env))) - || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env + || not (moduleUnitId mod `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env) || mod == gHC_PRIM) (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique.Set import GHC.Types.Fixity.Env import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State @@ -617,8 +618,8 @@ checkDependencies hsc_env summary iface all_home_units = hsc_all_home_unit_ids hsc_env units = hsc_units hsc_env prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) - prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) - (dep_plugin_pkgs (mi_deps iface))) + prev_dep_pkgs = uniqDSetToList (unionUniqDSets (dep_direct_pkgs (mi_deps iface)) + (dep_plugin_pkgs (mi_deps iface))) implicit_deps = map (fsLit "Implicit",) (implicitPackageDeps dflags) @@ -633,7 +634,7 @@ checkDependencies hsc_env summary iface classify _ (Found _ mod) - | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) + | (toUnitId $ moduleUnit mod) `elementOfUniqDSet` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -324,20 +324,20 @@ loadCmdLineLibs interp hsc_env = do loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState loadCmdLineLibs' interp hsc_env pls = snd <$> foldM - (\(done', pls') cur_uid -> load done' cur_uid pls') - (Set.empty, pls) - (hsc_all_home_unit_ids hsc_env) + (\(done', pls') cur_uid -> load done' cur_uid pls') + (emptyUniqDSet, pls) + (uniqDSetToList $ hsc_all_home_unit_ids hsc_env) where - load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState) - load done uid pls | uid `Set.member` done = return (done, pls) + load :: UnitIdSet -> UnitId -> LoaderState -> IO (UnitIdSet, LoaderState) + load done uid pls | uid `elementOfUniqDSet` done = return (done, pls) load done uid pls = do let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (homeUnitDepends (hsc_units hsc')) pls'' <- loadCmdLineLibs'' interp hsc' pls' - return $ (Set.insert uid done', pls'') + return $ (addOneToUniqDSet done' uid, pls'') loadCmdLineLibs'' :: Interp @@ -685,7 +685,7 @@ getLinkDeps :: HscEnv -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first + -> IO ([Linkable], [Linkable], [UnitId], UnitIdSet) -- ... then link these first -- The module and package dependencies for the needed modules are returned. -- See Note [Object File Dependencies] -- Fails with an IO exception if it can't find enough files @@ -737,7 +737,7 @@ getLinkDeps hsc_env pls replace_osuf span mods -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop :: (UnitIdSet, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UnitIdSet, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts @@ -766,7 +766,7 @@ getLinkDeps hsc_env pls replace_osuf span mods HsBootFile -> link_boot_mod_error (mi_module iface) _ -> return $ Just (mi_module iface) - in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod + in (dep_direct_pkgs (mi_deps iface),) <$> mmod Nothing -> let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid in throwGhcExceptionIO (ProgramError (showSDoc dflags err)) @@ -780,9 +780,9 @@ getLinkDeps hsc_env pls replace_osuf span mods -- dependencies of that. Hence we need to traverse the dependency -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow - -> UniqDSet Module -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([Module], UniqDSet UnitId) -- result + -> UniqDSet Module -- accum. module dependencies + -> UnitIdSet -- accum. package dependencies + -> IO ([Module], UnitIdSet) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -814,7 +814,7 @@ getLinkDeps hsc_env pls replace_osuf span mods acc_mods' = case hsc_home_unit_maybe hsc_env of Nothing -> acc_mods Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs (uniqDSetToList pkg_deps) case hsc_home_unit_maybe hsc_env of Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -37,7 +37,7 @@ module GHC.Linker.Types where import GHC.Prelude -import GHC.Unit ( UnitId, Module ) +import GHC.Unit ( UnitId, Module, UnitIdSet ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) import GHCi.RemoteTypes ( ForeignHValue ) @@ -53,7 +53,6 @@ import Control.Concurrent.MVar import Data.Time ( UTCTime ) import Data.Maybe import GHC.Unit.Module.Env -import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM import GHC.Unit.Module.WholeCoreBindings @@ -146,7 +145,7 @@ data LoadedPkgInfo { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] - , loaded_pkg_trans_deps :: UniqDSet UnitId + , loaded_pkg_trans_deps :: UnitIdSet } instance Outputable LoadedPkgInfo where ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -74,6 +74,7 @@ import GHC.Types.Id import GHC.Types.HpcInfo import GHC.Types.PkgQual import GHC.Types.GREInfo (ConInfo(..)) +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Module.Warnings @@ -212,8 +213,8 @@ rnImports imports = do let merged_import_avail = clobberSourceImports imp_avails dflags <- getDynFlags let final_import_avail = - merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags) - `S.union` imp_dep_direct_pkgs merged_import_avail} + merged_import_avail { imp_dep_direct_pkgs = mkUniqDSet (implicitPackageDeps dflags) + `unionUniqDSets` imp_dep_direct_pkgs merged_import_avail} return (decls, rdr_env, final_import_avail, hpc_usage) where @@ -480,7 +481,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit - -> S.Set UnitId + -> UnitIdSet -> ModIface -> IsSafeImport -> IsBootInterface @@ -535,7 +536,7 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by -- Trusted packages are a lot like orphans. trusted_pkgs | mod_safe' = dep_trusted_pkgs deps - | otherwise = S.empty + | otherwise = emptyUniqDSet pkg = moduleUnit (mi_module iface) @@ -548,11 +549,11 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by | isHomeUnit home_unit pkg = ptrust | otherwise = False - dependent_pkgs = if toUnitId pkg `S.member` other_home_units - then S.empty - else S.singleton ipkg + dependent_pkgs = if toUnitId pkg `elementOfUniqDSet` other_home_units + then emptyUniqDSet + else unitUniqDSet ipkg - direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units + direct_mods = mkModDeps $ if toUnitId pkg `elementOfUniqDSet` other_home_units then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) else S.empty ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -148,6 +148,7 @@ import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -185,7 +186,6 @@ import Data.List ( sortBy, sort ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.Ord -import qualified Data.Set as S import Data.Traversable ( for ) @@ -3134,7 +3134,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , text "Dependent modules:" <+> (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_direct_pkgs imports)] + ppr (uniqDSetToAscList $ imp_dep_direct_pkgs imports)] -- The use of sort is just to reduce unnecessary -- wobbling in testsuite output ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -142,6 +142,7 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo @@ -1367,9 +1368,9 @@ plusModDeps = plusInstalledModuleEnv plus_mod_dep emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, imp_direct_dep_mods = emptyInstalledModuleEnv, - imp_dep_direct_pkgs = S.empty, + imp_dep_direct_pkgs = emptyUniqDSet, imp_sig_mods = [], - imp_trust_pkgs = S.empty, + imp_trust_pkgs = emptyUniqDSet, imp_trust_own_pkg = False, imp_boot_mods = emptyInstalledModuleEnv, imp_orphs = [], @@ -1398,8 +1399,8 @@ plusImportAvails imp_orphs = orphs2, imp_finsts = finsts2 }) = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2, - imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, - imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, + imp_dep_direct_pkgs = ddpkgs1 `unionUniqDSets` ddpkgs2, + imp_trust_pkgs = tpkgs1 `unionUniqDSets` tpkgs2, imp_trust_own_pkg = tself1 || tself2, imp_boot_mods = srs1 `plusModDeps` srcs2, imp_sig_mods = unionListsOrd sig_mods1 sig_mods2, ===================================== compiler/GHC/Types/Unique/DSet.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Types.Unique.DSet ( isEmptyUniqDSet, lookupUniqDSet, uniqDSetToList, + uniqDSetToAscList, partitionUniqDSet, mapUniqDSet ) where @@ -43,8 +44,11 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique +import GHC.Utils.Binary + import Data.Coerce import Data.Data +import Data.List (sort) -- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. -- Beyond preserving invariants, we may also want to 'override' typeclass @@ -120,6 +124,9 @@ lookupUniqDSet = lookupUDFM . getUniqDSet uniqDSetToList :: UniqDSet a -> [a] uniqDSetToList = eltsUDFM . getUniqDSet +uniqDSetToAscList :: Ord a => UniqDSet a -> [a] +uniqDSetToAscList = sort . uniqDSetToList + partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet @@ -140,3 +147,7 @@ instance Outputable a => Outputable (UniqDSet a) where pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList + +instance (Uniquable a, Binary a, Ord a) => Binary (UniqDSet a) where + put_ bh = put_ bh . uniqDSetToAscList + get bh = mkUniqDSet <$> get bh ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -81,6 +81,7 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic (pprPanic) +import GHC.Types.Unique.DSet import GHC.Unit.Module.ModIface import GHC.Unit.Module import qualified Data.Set as Set @@ -339,8 +340,8 @@ unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env -unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey -unitEnv_keys env = Map.keysSet (unitEnv_graph env) +unitEnv_keys :: UnitEnvGraph v -> UnitIdSet +unitEnv_keys env = mkUniqDSet $ Map.keys (unitEnv_graph env) unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)] unitEnv_elts env = Map.toList (unitEnv_graph env) @@ -443,7 +444,7 @@ ue_unitHomeUnit_maybe uid ue_env = ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env -ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId +ue_all_home_unit_ids :: UnitEnv -> UnitIdSet ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.State +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint import GHC.Utils.Binary @@ -53,13 +54,13 @@ data Dependencies = Deps -- ^ All home-package modules which are directly imported by this one. -- This may include modules from other units when using multiple home units - , dep_direct_pkgs :: Set UnitId + , dep_direct_pkgs :: UnitIdSet -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. -- Does not include other home units when using multiple home units. -- Modules from these units will go in `dep_direct_mods` - , dep_plugin_pkgs :: Set UnitId + , dep_plugin_pkgs :: UnitIdSet -- ^ All units needed for plugins ------------------------------------ @@ -69,7 +70,7 @@ data Dependencies = Deps -- ^ Transitive closure of hsig files in the home package - , dep_trusted_pkgs :: Set UnitId + , dep_trusted_pkgs :: UnitIdSet -- Packages which we are required to trust -- when the module is imported as a safe import -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names @@ -110,7 +111,7 @@ data Dependencies = Deps mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies mkDependencies home_unit mod imports plugin_mods = let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods - plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins) + plugin_units = mkUniqDSet (map (toUnitId . moduleUnit) external_plugins) all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot)) (imp_direct_dep_mods imports) (map (fmap toUnitId) home_plugins) @@ -197,12 +198,12 @@ instance Binary Dependencies where noDependencies :: Dependencies noDependencies = Deps - { dep_direct_mods = Set.empty - , dep_direct_pkgs = Set.empty - , dep_plugin_pkgs = Set.empty + { dep_direct_mods = mempty + , dep_direct_pkgs = emptyUniqDSet + , dep_plugin_pkgs = emptyUniqDSet , dep_sig_mods = [] - , dep_boot_mods = Set.empty - , dep_trusted_pkgs = Set.empty + , dep_boot_mods = mempty + , dep_trusted_pkgs = emptyUniqDSet , dep_orphs = [] , dep_finsts = [] } @@ -220,11 +221,11 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, text "boot module dependencies:" <+> ppr_set ppr bmods, - text "direct package dependencies:" <+> ppr_set ppr pkgs, - text "plugin package dependencies:" <+> ppr_set ppr plgns, - if null tps + text "direct package dependencies:" <+> ppr_unitIdSet ppr pkgs, + text "plugin package dependencies:" <+> ppr_unitIdSet ppr plgns, + if isEmptyUniqDSet tps then empty - else text "trusted package dependencies:" <+> ppr_set ppr tps, + else text "trusted package dependencies:" <+> ppr_unitIdSet ppr tps, text "orphans:" <+> fsep (map ppr orphs), text "family instance modules:" <+> fsep (map ppr finsts) ] @@ -235,6 +236,9 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc ppr_set w = fsep . fmap w . Set.toAscList + ppr_unitIdSet :: (UnitId -> SDoc) -> UnitIdSet -> SDoc + ppr_unitIdSet w = fsep . fmap w . sort . uniqDSetToList + -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance -- @@ -491,7 +495,7 @@ data ImportAvails imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot, -- ^ Home-package modules directly imported by the module being compiled. - imp_dep_direct_pkgs :: Set UnitId, + imp_dep_direct_pkgs :: UnitIdSet, -- ^ Packages directly needed by the module being compiled imp_trust_own_pkg :: Bool, @@ -502,7 +506,7 @@ data ImportAvails -- Transitive information below here - imp_trust_pkgs :: Set UnitId, + imp_trust_pkgs :: UnitIdSet, -- ^ This records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if ===================================== compiler/GHC/Unit/Module/ModGuts.hs ===================================== @@ -37,8 +37,6 @@ import GHC.Types.SourceFile ( HscSource(..), hscSourceToIsBoot ) import GHC.Types.SrcLoc import GHC.Types.CostCentre -import Data.Set (Set) - -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module @@ -137,7 +135,7 @@ data CgGuts cg_ccs :: [CostCentre], -- List of cost centres used in bindings and rules cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_foreign_files :: ![(ForeignSrcLang, FilePath)], - cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to + cg_dep_pkgs :: !UnitIdSet, -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -346,10 +346,10 @@ data UnitConfig = UnitConfig , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units - , unitConfigHomeUnits :: Set.Set UnitId + , unitConfigHomeUnits :: UnitIdSet } -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> UnitConfig initUnitConfig dflags cached_dbs home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags @@ -626,7 +626,7 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) initUnits logger dflags cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () @@ -1362,7 +1362,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> text db_path - forM_ (Set.toList override_set) $ \pkg -> + forM_ (uniqDSetToList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> text "overrides a previously defined package" @@ -1374,9 +1374,9 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] -- The set of UnitIds which appear in both db and pkgs. These are the -- ones that get overridden. Compute this just to give some -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) + override_set :: UnitIdSet + override_set = intersectUniqDSets (mkUniqDSet $ nonDetKeysUniqMap db_map) + (mkUniqDSet $ nonDetKeysUniqMap pkg_map) -- Now merge the sets together (NB: in case of duplicate, -- first argument preferred) @@ -1688,7 +1688,7 @@ mkUnitState logger cfg = do let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = uniqDSetToList home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map @@ -1701,15 +1701,15 @@ mkUnitState logger cfg = do } return (state, raw_dbs) -selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool -selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True +selectHptFlag :: UnitIdSet -> PackageFlag -> Bool +selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = True selectHptFlag _ _ = False -selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId -selectHomeUnits home_units flags = foldl' go Set.empty flags +selectHomeUnits :: UnitIdSet -> [PackageFlag] -> UnitIdSet +selectHomeUnits home_units flags = foldl' go emptyUniqDSet flags where - go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId - go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur + go :: UnitIdSet -> PackageFlag -> UnitIdSet + go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = addOneToUniqDSet cur (toUnitId uid) -- MP: This does not yet support thinning/renaming go cur _ = cur ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -33,6 +33,7 @@ module GHC.Unit.Types , GenInstantiatedUnit (..) , InstantiatedUnit , DefUnitId + , UnitIdSet , Instantiations , GenInstantiations , mkInstantiatedUnit @@ -538,6 +539,8 @@ pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- code for. type DefUnitId = Definite UnitId +type UnitIdSet = UniqDSet UnitId + unitIdString :: UnitId -> String unitIdString = unpackFS . unitIdFS ===================================== ghc/GHCi/UI.hs ===================================== @@ -105,6 +105,7 @@ import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Bag (unitBag) import qualified GHC.Data.Strict as Strict +import GHC.Types.Unique.DSet -- Haskell Libraries import System.Console.Haskeline as Haskeline @@ -125,7 +126,6 @@ import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.List.NonEmpty as NE -import qualified Data.Set as S import Data.Maybe import qualified Data.Map as M import Data.IntMap.Strict (IntMap) @@ -561,7 +561,7 @@ interactiveUI config srcs maybe_exprs = do -- Set to True because Prelude is implicitly imported. impDecl at ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}} hsc_env <- GHC.getSession - let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1 + let in_multi = sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 empty_cache <- liftIO newIfaceCache startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, @@ -2568,15 +2568,15 @@ isSafeModule m = do -- print info to user... liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") - when (not $ S.null good) + when (not $ isEmptyUniqDSet good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ - (intercalate ", " $ map (showPpr dflags) (S.toList good))) - case msafe && S.null bad of + (intercalate ", " $ map (showPpr dflags) (uniqDSetToList good))) + case msafe && isEmptyUniqDSet bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do - when (not $ null bad) + when (not $ isEmptyUniqDSet bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " - ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad))) + ++ (intercalate ", " $ map (showPpr dflags) (uniqDSetToList bad))) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where @@ -2586,8 +2586,8 @@ isSafeModule m = do | isHomeModule (hsc_home_unit hsc_env) md = True | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md) - tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty) - | otherwise = S.partition part deps + tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (emptyUniqDSet, emptyUniqDSet) + | otherwise = partitionUniqDSet part deps where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg unit_state = hsc_units hsc_env dflags = hsc_dflags hsc_env View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df356143037d434abca9118e6ebb47a443069dee -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df356143037d434abca9118e6ebb47a443069dee You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed May 3 15:46:37 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Wed, 03 May 2023 11:46:37 -0400 Subject: [Git][ghc/ghc][wip/supersven/aarch64_stackFrameSize] 51 commits: Show an error when we cannot default a concrete tyvar Message-ID: <645281ddf2293_3c91151dfe08cc3700f7@gitlab.mail> Sven Tennie pushed to branch wip/supersven/aarch64_stackFrameSize at Glasgow Haskell Compiler / GHC Commits: 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - ce03892e by Sven Tennie at 2023-05-03T15:46:32+00:00 Adjust AArch64 stackFrameHeaderSize The prologue of each stack frame are the saved LR and FP registers, 8 byte each. I.e. the size of the stack frame header is 2 * 8 byte. - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Config/Diagnostic.hs - compiler/GHC/Driver/Config/Tidy.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Make.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4d192e9413544f45d164e896b2f736f65f3de965...ce03892ec20c695313d852794ae21627b4764754 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4d192e9413544f45d164e896b2f736f65f3de965...ce03892ec20c695313d852794ae21627b4764754 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 00:16:46 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 May 2023 20:16:46 -0400 Subject: [Git][ghc/ghc][master] Add sized primitive literal syntax Message-ID: <6452f96ebb97b_e3e0651e784172b@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - 26 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Lit.hs - docs/users_guide/9.8.1-notes.rst - + docs/users_guide/exts/extended_literals.rst - docs/users_guide/exts/literals.rst - docs/users_guide/exts/primitives.rst - docs/users_guide/exts/stolen_syntax.rst - libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs - testsuite/tests/driver/T4437.hs - + testsuite/tests/extendedliterals/all.T - + testsuite/tests/extendedliterals/extendedliterals01.hs - + testsuite/tests/extendedliterals/extendedliterals02.hs - + testsuite/tests/extendedliterals/extendedliterals03.hs - + testsuite/tests/extendedliterals/extendedliterals03.stdout - − testsuite/tests/ghci/should_run/SizedLiterals.hs - − testsuite/tests/ghci/should_run/SizedLiteralsA.hs - testsuite/tests/ghci/should_run/all.T - testsuite/tests/printer/Ppr038.hs - utils/check-exact/ExactPrint.hs - utils/haddock Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3758,6 +3758,7 @@ xFlagsDeps = [ flagSpec "ExplicitForAll" LangExt.ExplicitForAll, flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, + flagSpec "ExtendedLiterals" LangExt.ExtendedLiterals, flagSpec "FlexibleContexts" LangExt.FlexibleContexts, flagSpec "FlexibleInstances" LangExt.FlexibleInstances, flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, ===================================== compiler/GHC/Hs/Lit.hs ===================================== @@ -50,7 +50,13 @@ type instance XHsStringPrim (GhcPass _) = SourceText type instance XHsInt (GhcPass _) = NoExtField type instance XHsIntPrim (GhcPass _) = SourceText type instance XHsWordPrim (GhcPass _) = SourceText +type instance XHsInt8Prim (GhcPass _) = SourceText +type instance XHsInt16Prim (GhcPass _) = SourceText +type instance XHsInt32Prim (GhcPass _) = SourceText type instance XHsInt64Prim (GhcPass _) = SourceText +type instance XHsWord8Prim (GhcPass _) = SourceText +type instance XHsWord16Prim (GhcPass _) = SourceText +type instance XHsWord32Prim (GhcPass _) = SourceText type instance XHsWord64Prim (GhcPass _) = SourceText type instance XHsInteger (GhcPass _) = SourceText type instance XHsRat (GhcPass _) = NoExtField @@ -128,14 +134,20 @@ hsLitNeedsParens p = go go (HsString {}) = False go (HsStringPrim {}) = False go (HsInt _ x) = p > topPrec && il_neg x - go (HsIntPrim {}) = False - go (HsWordPrim {}) = False - go (HsInt64Prim {}) = False - go (HsWord64Prim {}) = False go (HsInteger _ x _) = p > topPrec && x < 0 go (HsRat _ x _) = p > topPrec && fl_neg x go (HsFloatPrim {}) = False go (HsDoublePrim {}) = False + go (HsIntPrim {}) = False + go (HsInt8Prim {}) = False + go (HsInt16Prim {}) = False + go (HsInt32Prim {}) = False + go (HsInt64Prim {}) = False + go (HsWordPrim {}) = False + go (HsWord8Prim {}) = False + go (HsWord16Prim {}) = False + go (HsWord64Prim {}) = False + go (HsWord32Prim {}) = False go (XLit _) = False -- | Convert a literal from one index type to another @@ -147,7 +159,13 @@ convertLit (HsStringPrim a x) = HsStringPrim a x convertLit (HsInt a x) = HsInt a x convertLit (HsIntPrim a x) = HsIntPrim a x convertLit (HsWordPrim a x) = HsWordPrim a x +convertLit (HsInt8Prim a x) = HsInt8Prim a x +convertLit (HsInt16Prim a x) = HsInt16Prim a x +convertLit (HsInt32Prim a x) = HsInt32Prim a x convertLit (HsInt64Prim a x) = HsInt64Prim a x +convertLit (HsWord8Prim a x) = HsWord8Prim a x +convertLit (HsWord16Prim a x) = HsWord16Prim a x +convertLit (HsWord32Prim a x) = HsWord32Prim a x convertLit (HsWord64Prim a x) = HsWord64Prim a x convertLit (HsInteger a x b) = HsInteger a x b convertLit (HsRat a x b) = HsRat a x b @@ -182,8 +200,14 @@ instance Outputable (HsLit (GhcPass p)) where ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) - ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsInt8Prim st i) = pprWithSourceText st (pprPrimInt8 i) + ppr (HsInt16Prim st i) = pprWithSourceText st (pprPrimInt16 i) + ppr (HsInt32Prim st i) = pprWithSourceText st (pprPrimInt32 i) ppr (HsInt64Prim st i) = pprWithSourceText st (pprPrimInt64 i) + ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsWord8Prim st w) = pprWithSourceText st (pprPrimWord8 w) + ppr (HsWord16Prim st w) = pprWithSourceText st (pprPrimWord16 w) + ppr (HsWord32Prim st w) = pprWithSourceText st (pprPrimWord32 w) ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w) -- in debug mode, print the expression that it's resolved to, too @@ -211,7 +235,13 @@ pmPprHsLit (HsStringPrim _ s) = pprHsBytes s pmPprHsLit (HsInt _ i) = integer (il_value i) pmPprHsLit (HsIntPrim _ i) = integer i pmPprHsLit (HsWordPrim _ w) = integer w +pmPprHsLit (HsInt8Prim _ i) = integer i +pmPprHsLit (HsInt16Prim _ i) = integer i +pmPprHsLit (HsInt32Prim _ i) = integer i pmPprHsLit (HsInt64Prim _ i) = integer i +pmPprHsLit (HsWord8Prim _ w) = integer w +pmPprHsLit (HsWord16Prim _ w) = integer w +pmPprHsLit (HsWord32Prim _ w) = integer w pmPprHsLit (HsWord64Prim _ w) = integer w pmPprHsLit (HsInteger _ i _) = integer i pmPprHsLit (HsRat _ f _) = ppr f ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -77,7 +77,13 @@ hsLitType (HsStringPrim _ _) = addrPrimTy hsLitType (HsInt _ _) = intTy hsLitType (HsIntPrim _ _) = intPrimTy hsLitType (HsWordPrim _ _) = wordPrimTy +hsLitType (HsInt8Prim _ _) = int8PrimTy +hsLitType (HsInt16Prim _ _) = int16PrimTy +hsLitType (HsInt32Prim _ _) = int32PrimTy hsLitType (HsInt64Prim _ _) = int64PrimTy +hsLitType (HsWord8Prim _ _) = word8PrimTy +hsLitType (HsWord16Prim _ _) = word16PrimTy +hsLitType (HsWord32Prim _ _) = word32PrimTy hsLitType (HsWord64Prim _ _) = word64PrimTy hsLitType (HsInteger _ _ ty) = ty hsLitType (HsRat _ _ ty) = ty ===================================== compiler/GHC/HsToCore/Match/Literal.hs ===================================== @@ -106,7 +106,13 @@ dsLit l = do HsCharPrim _ c -> return (Lit (LitChar c)) HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i)) HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w)) + HsInt8Prim _ i -> return (Lit (mkLitInt8Wrap i)) + HsInt16Prim _ i -> return (Lit (mkLitInt16Wrap i)) + HsInt32Prim _ i -> return (Lit (mkLitInt32Wrap i)) HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap i)) + HsWord8Prim _ w -> return (Lit (mkLitWord8Wrap w)) + HsWord16Prim _ w -> return (Lit (mkLitWord16Wrap w)) + HsWord32Prim _ w -> return (Lit (mkLitWord32Wrap w)) HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w)) -- This can be slow for very large literals. See Note [FractionalLit representation] @@ -455,10 +461,23 @@ getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type) getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy) getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy) getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy) +getSimpleIntegralLit (HsInt8Prim _ i) = Just (i, int8PrimTy) +getSimpleIntegralLit (HsInt16Prim _ i) = Just (i, int16PrimTy) +getSimpleIntegralLit (HsInt32Prim _ i) = Just (i, int32PrimTy) getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy) +getSimpleIntegralLit (HsWord8Prim _ i) = Just (i, word8PrimTy) +getSimpleIntegralLit (HsWord16Prim _ i) = Just (i, word16PrimTy) +getSimpleIntegralLit (HsWord32Prim _ i) = Just (i, word32PrimTy) getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy) getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty) -getSimpleIntegralLit _ = Nothing + +getSimpleIntegralLit HsChar{} = Nothing +getSimpleIntegralLit HsCharPrim{} = Nothing +getSimpleIntegralLit HsString{} = Nothing +getSimpleIntegralLit HsStringPrim{} = Nothing +getSimpleIntegralLit HsRat{} = Nothing +getSimpleIntegralLit HsFloatPrim{} = Nothing +getSimpleIntegralLit HsDoublePrim{} = Nothing -- | Extract the Char if the expression is a Char literal. getLHsCharLit :: LHsExpr GhcTc -> Maybe Char @@ -638,7 +657,13 @@ hsLitKey :: Platform -> HsLit GhcTc -> Literal -- HsLit does not. hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w +hsLitKey _ (HsInt8Prim _ i) = mkLitInt8Wrap i +hsLitKey _ (HsInt16Prim _ i) = mkLitInt16Wrap i +hsLitKey _ (HsInt32Prim _ i) = mkLitInt32Wrap i hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i +hsLitKey _ (HsWord8Prim _ w) = mkLitWord8Wrap w +hsLitKey _ (HsWord16Prim _ w) = mkLitWord16Wrap w +hsLitKey _ (HsWord32Prim _ w) = mkLitWord32Wrap w hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w hsLitKey _ (HsCharPrim _ c) = mkLitChar c -- This following two can be slow. See Note [FractionalLit representation] ===================================== compiler/GHC/Parser.y ===================================== @@ -718,6 +718,14 @@ are the most common patterns, rewritten as regular expressions for clarity: PRIMSTRING { L _ (ITprimstring _ _) } PRIMINTEGER { L _ (ITprimint _ _) } PRIMWORD { L _ (ITprimword _ _) } + PRIMINTEGER8 { L _ (ITprimint8 _ _) } + PRIMINTEGER16 { L _ (ITprimint16 _ _) } + PRIMINTEGER32 { L _ (ITprimint32 _ _) } + PRIMINTEGER64 { L _ (ITprimint64 _ _) } + PRIMWORD8 { L _ (ITprimword8 _ _) } + PRIMWORD16 { L _ (ITprimword16 _ _) } + PRIMWORD32 { L _ (ITprimword32 _ _) } + PRIMWORD64 { L _ (ITprimword64 _ _) } PRIMFLOAT { L _ (ITprimfloat _) } PRIMDOUBLE { L _ (ITprimdouble _) } @@ -3873,6 +3881,22 @@ literal :: { Located (HsLit GhcPs) } $ getPRIMINTEGER $1 } | PRIMWORD { sL1 $1 $ HsWordPrim (getPRIMWORDs $1) $ getPRIMWORD $1 } + | PRIMINTEGER8 { sL1 $1 $ HsInt8Prim (getPRIMINTEGER8s $1) + $ getPRIMINTEGER8 $1 } + | PRIMINTEGER16 { sL1 $1 $ HsInt16Prim (getPRIMINTEGER16s $1) + $ getPRIMINTEGER16 $1 } + | PRIMINTEGER32 { sL1 $1 $ HsInt32Prim (getPRIMINTEGER32s $1) + $ getPRIMINTEGER32 $1 } + | PRIMINTEGER64 { sL1 $1 $ HsInt64Prim (getPRIMINTEGER64s $1) + $ getPRIMINTEGER64 $1 } + | PRIMWORD8 { sL1 $1 $ HsWord8Prim (getPRIMWORD8s $1) + $ getPRIMWORD8 $1 } + | PRIMWORD16 { sL1 $1 $ HsWord16Prim (getPRIMWORD16s $1) + $ getPRIMWORD16 $1 } + | PRIMWORD32 { sL1 $1 $ HsWord32Prim (getPRIMWORD32s $1) + $ getPRIMWORD32 $1 } + | PRIMWORD64 { sL1 $1 $ HsWord64Prim (getPRIMWORD64s $1) + $ getPRIMWORD64 $1 } | PRIMCHAR { sL1 $1 $ HsCharPrim (getPRIMCHARs $1) $ getPRIMCHAR $1 } | PRIMSTRING { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1) @@ -3913,43 +3937,59 @@ bars :: { ([SrcSpan],Int) } -- One or more bars happyError :: P a happyError = srcParseFail -getVARID (L _ (ITvarid x)) = x -getCONID (L _ (ITconid x)) = x -getVARSYM (L _ (ITvarsym x)) = x -getCONSYM (L _ (ITconsym x)) = x -getDO (L _ (ITdo x)) = x -getMDO (L _ (ITmdo x)) = x -getQVARID (L _ (ITqvarid x)) = x -getQCONID (L _ (ITqconid x)) = x -getQVARSYM (L _ (ITqvarsym x)) = x -getQCONSYM (L _ (ITqconsym x)) = x -getIPDUPVARID (L _ (ITdupipvarid x)) = x -getLABELVARID (L _ (ITlabelvarid _ x)) = x -getCHAR (L _ (ITchar _ x)) = x -getSTRING (L _ (ITstring _ x)) = x -getINTEGER (L _ (ITinteger x)) = x -getRATIONAL (L _ (ITrational x)) = x -getPRIMCHAR (L _ (ITprimchar _ x)) = x -getPRIMSTRING (L _ (ITprimstring _ x)) = x -getPRIMINTEGER (L _ (ITprimint _ x)) = x -getPRIMWORD (L _ (ITprimword _ x)) = x -getPRIMFLOAT (L _ (ITprimfloat x)) = x -getPRIMDOUBLE (L _ (ITprimdouble x)) = x -getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline src,FunLike) -getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike) +getVARID (L _ (ITvarid x)) = x +getCONID (L _ (ITconid x)) = x +getVARSYM (L _ (ITvarsym x)) = x +getCONSYM (L _ (ITconsym x)) = x +getDO (L _ (ITdo x)) = x +getMDO (L _ (ITmdo x)) = x +getQVARID (L _ (ITqvarid x)) = x +getQCONID (L _ (ITqconid x)) = x +getQVARSYM (L _ (ITqvarsym x)) = x +getQCONSYM (L _ (ITqconsym x)) = x +getIPDUPVARID (L _ (ITdupipvarid x)) = x +getLABELVARID (L _ (ITlabelvarid _ x)) = x +getCHAR (L _ (ITchar _ x)) = x +getSTRING (L _ (ITstring _ x)) = x +getINTEGER (L _ (ITinteger x)) = x +getRATIONAL (L _ (ITrational x)) = x +getPRIMCHAR (L _ (ITprimchar _ x)) = x +getPRIMSTRING (L _ (ITprimstring _ x)) = x +getPRIMINTEGER (L _ (ITprimint _ x)) = x +getPRIMWORD (L _ (ITprimword _ x)) = x +getPRIMINTEGER8 (L _ (ITprimint8 _ x)) = x +getPRIMINTEGER16 (L _ (ITprimint16 _ x)) = x +getPRIMINTEGER32 (L _ (ITprimint32 _ x)) = x +getPRIMINTEGER64 (L _ (ITprimint64 _ x)) = x +getPRIMWORD8 (L _ (ITprimword8 _ x)) = x +getPRIMWORD16 (L _ (ITprimword16 _ x)) = x +getPRIMWORD32 (L _ (ITprimword32 _ x)) = x +getPRIMWORD64 (L _ (ITprimword64 _ x)) = x +getPRIMFLOAT (L _ (ITprimfloat x)) = x +getPRIMDOUBLE (L _ (ITprimdouble x)) = x +getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline src,FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike) getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x -getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l - -getINTEGERs (L _ (ITinteger (IL src _ _))) = src -getCHARs (L _ (ITchar src _)) = src -getSTRINGs (L _ (ITstring src _)) = src -getPRIMCHARs (L _ (ITprimchar src _)) = src -getPRIMSTRINGs (L _ (ITprimstring src _)) = src -getPRIMINTEGERs (L _ (ITprimint src _)) = src -getPRIMWORDs (L _ (ITprimword src _)) = src - -getLABELVARIDs (L _ (ITlabelvarid src _)) = src +getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l + +getINTEGERs (L _ (ITinteger (IL src _ _))) = src +getCHARs (L _ (ITchar src _)) = src +getSTRINGs (L _ (ITstring src _)) = src +getPRIMCHARs (L _ (ITprimchar src _)) = src +getPRIMSTRINGs (L _ (ITprimstring src _)) = src +getPRIMINTEGERs (L _ (ITprimint src _)) = src +getPRIMWORDs (L _ (ITprimword src _)) = src +getPRIMINTEGER8s (L _ (ITprimint8 src _)) = src +getPRIMINTEGER16s (L _ (ITprimint16 src _)) = src +getPRIMINTEGER32s (L _ (ITprimint32 src _)) = src +getPRIMINTEGER64s (L _ (ITprimint64 src _)) = src +getPRIMWORD8s (L _ (ITprimword8 src _)) = src +getPRIMWORD16s (L _ (ITprimword16 src _)) = src +getPRIMWORD32s (L _ (ITprimword32 src _)) = src +getPRIMWORD64s (L _ (ITprimword64 src _)) = src + +getLABELVARIDs (L _ (ITlabelvarid src _)) = src -- See Note [Pragma source text] in "GHC.Types.SourceText" for the following getINLINE_PRAGs (L _ (ITinline_prag _ inl _)) = inlineSpecSource inl ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -194,6 +194,10 @@ $docsym = [\| \^ \* \$] @exponent = @numspc [eE] [\-\+]? @decimal @bin_exponent = @numspc [pP] [\-\+]? @decimal + at binarylit = 0[bB] @numspc @binary + at octallit = 0[oO] @numspc @octal + at hexadecimallit = 0[xX] @numspc @hexadecimal + @qual = (@conid \.)+ @qvarid = @qual @varid @qconid = @qual @conid @@ -517,15 +521,15 @@ $unigraphic / { isSmartQuote } { smart_quote_error } -- <0> { -- Normal integral literals (:: Num a => a, from Integer) - @decimal { tok_num positive 0 0 decimal } - 0[bB] @numspc @binary / { ifExtension BinaryLiteralsBit } { tok_num positive 2 2 binary } - 0[oO] @numspc @octal { tok_num positive 2 2 octal } - 0[xX] @numspc @hexadecimal { tok_num positive 2 2 hexadecimal } - @negative @decimal / { negLitPred } { tok_num negative 1 1 decimal } - @negative 0[bB] @numspc @binary / { negLitPred `alexAndPred` - ifExtension BinaryLiteralsBit } { tok_num negative 3 3 binary } - @negative 0[oO] @numspc @octal / { negLitPred } { tok_num negative 3 3 octal } - @negative 0[xX] @numspc @hexadecimal / { negLitPred } { tok_num negative 3 3 hexadecimal } + @decimal { tok_num positive 0 0 decimal } + @binarylit / { ifExtension BinaryLiteralsBit } { tok_num positive 2 2 binary } + @octallit { tok_num positive 2 2 octal } + @hexadecimallit { tok_num positive 2 2 hexadecimal } + @negative @decimal / { negLitPred } { tok_num negative 1 1 decimal } + @negative @binarylit / { negLitPred `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_num negative 3 3 binary } + @negative @octallit / { negLitPred } { tok_num negative 3 3 octal } + @negative @hexadecimallit / { negLitPred } { tok_num negative 3 3 hexadecimal } -- Normal rational literals (:: Fractional a => a, from Rational) @floating_point { tok_frac 0 tok_float } @@ -540,31 +544,116 @@ $unigraphic / { isSmartQuote } { smart_quote_error } -- Unboxed ints (:: Int#) and words (:: Word#) -- It's simpler (and faster?) to give separate cases to the negatives, -- especially considering octal/hexadecimal prefixes. - @decimal \# / { ifExtension MagicHashBit } { tok_primint positive 0 1 decimal } - 0[bB] @numspc @binary \# / { ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit } { tok_primint positive 2 3 binary } - 0[oO] @numspc @octal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 octal } - 0[xX] @numspc @hexadecimal \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 hexadecimal } - @negative @decimal \# / { negHashLitPred } { tok_primint negative 1 2 decimal } - @negative 0[bB] @numspc @binary \# / { negHashLitPred `alexAndPred` - ifExtension BinaryLiteralsBit } { tok_primint negative 3 4 binary } - @negative 0[oO] @numspc @octal \# / { negHashLitPred } { tok_primint negative 3 4 octal } - @negative 0[xX] @numspc @hexadecimal \# - / { negHashLitPred } { tok_primint negative 3 4 hexadecimal } - - @decimal \# \# / { ifExtension MagicHashBit } { tok_primword 0 2 decimal } - 0[bB] @numspc @binary \# \# / { ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit } { tok_primword 2 4 binary } - 0[oO] @numspc @octal \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 octal } - 0[xX] @numspc @hexadecimal \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 hexadecimal } + @decimal \# / { ifExtension MagicHashBit } { tok_primint positive 0 1 decimal } + @binarylit \# / { ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint positive 2 3 binary } + @octallit \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 octal } + @hexadecimallit \# / { ifExtension MagicHashBit } { tok_primint positive 2 3 hexadecimal } + @negative @decimal \# / { negHashLitPred MagicHashBit } { tok_primint negative 1 2 decimal } + @negative @binarylit \# / { negHashLitPred MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint negative 3 4 binary } + @negative @octallit \# / { negHashLitPred MagicHashBit } { tok_primint negative 3 4 octal } + @negative @hexadecimallit \# / { negHashLitPred MagicHashBit } { tok_primint negative 3 4 hexadecimal } + + @decimal \# \# / { ifExtension MagicHashBit } { tok_primword 0 2 decimal } + @binarylit \# \# / { ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primword 2 4 binary } + @octallit \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 octal } + @hexadecimallit \# \# / { ifExtension MagicHashBit } { tok_primword 2 4 hexadecimal } -- Unboxed floats and doubles (:: Float#, :: Double#) -- prim_{float,double} work with signed literals @floating_point \# / { ifExtension MagicHashBit } { tok_frac 1 tok_primfloat } @floating_point \# \# / { ifExtension MagicHashBit } { tok_frac 2 tok_primdouble } - @negative @floating_point \# / { negHashLitPred } { tok_frac 1 tok_primfloat } - @negative @floating_point \# \# / { negHashLitPred } { tok_frac 2 tok_primdouble } + @negative @floating_point \# / { negHashLitPred MagicHashBit } { tok_frac 1 tok_primfloat } + @negative @floating_point \# \# / { negHashLitPred MagicHashBit } { tok_frac 2 tok_primdouble } + + @decimal \#"Int8" / { ifExtension ExtendedLiteralsBit } { tok_primint8 positive 0 decimal } + @binarylit \#"Int8" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint8 positive 2 binary } + @octallit \#"Int8" / { ifExtension ExtendedLiteralsBit } { tok_primint8 positive 2 octal } + @hexadecimallit \#"Int8" / { ifExtension ExtendedLiteralsBit } { tok_primint8 positive 2 hexadecimal } + @negative @decimal \#"Int8" / { negHashLitPred ExtendedLiteralsBit } { tok_primint8 negative 1 decimal } + @negative @binarylit \#"Int8" / { negHashLitPred ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint8 negative 3 binary } + @negative @octallit \#"Int8" / { negHashLitPred ExtendedLiteralsBit } { tok_primint8 negative 3 octal } + @negative @hexadecimallit \#"Int8" / { negHashLitPred ExtendedLiteralsBit } { tok_primint8 negative 3 hexadecimal } + + @decimal \#"Int16" / { ifExtension ExtendedLiteralsBit } { tok_primint16 positive 0 decimal } + @binarylit \#"Int16" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint16 positive 2 binary } + @octallit \#"Int16" / { ifExtension ExtendedLiteralsBit } { tok_primint16 positive 2 octal } + @hexadecimallit \#"Int16" / { ifExtension ExtendedLiteralsBit } { tok_primint16 positive 2 hexadecimal } + @negative @decimal \#"Int16" / { negHashLitPred ExtendedLiteralsBit} { tok_primint16 negative 1 decimal } + @negative @binarylit \#"Int16" / { negHashLitPred ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint16 negative 3 binary } + @negative @octallit \#"Int16" / { negHashLitPred ExtendedLiteralsBit} { tok_primint16 negative 3 octal } + @negative @hexadecimallit \#"Int16" / { negHashLitPred ExtendedLiteralsBit} { tok_primint16 negative 3 hexadecimal } + + @decimal \#"Int32" / { ifExtension ExtendedLiteralsBit } { tok_primint32 positive 0 decimal } + @binarylit \#"Int32" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint32 positive 2 binary } + @octallit \#"Int32" / { ifExtension ExtendedLiteralsBit } { tok_primint32 positive 2 octal } + @hexadecimallit \#"Int32" / { ifExtension ExtendedLiteralsBit } { tok_primint32 positive 2 hexadecimal } + @negative @decimal \#"Int32" / { negHashLitPred ExtendedLiteralsBit } { tok_primint32 negative 1 decimal } + @negative @binarylit \#"Int32" / { negHashLitPred ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint32 negative 3 binary } + @negative @octallit \#"Int32" / { negHashLitPred ExtendedLiteralsBit} { tok_primint32 negative 3 octal } + @negative @hexadecimallit \#"Int32" / { negHashLitPred ExtendedLiteralsBit} { tok_primint32 negative 3 hexadecimal } + + @decimal \#"Int64" / { ifExtension ExtendedLiteralsBit } { tok_primint64 positive 0 decimal } + @binarylit \#"Int64" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint64 positive 2 binary } + @octallit \#"Int64" / { ifExtension ExtendedLiteralsBit } { tok_primint64 positive 2 octal } + @hexadecimallit \#"Int64" / { ifExtension ExtendedLiteralsBit } { tok_primint64 positive 2 hexadecimal } + @negative @decimal \#"Int64" / { negHashLitPred ExtendedLiteralsBit } { tok_primint64 negative 1 decimal } + @negative @binarylit \#"Int64" / { negHashLitPred ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint64 negative 3 binary } + @negative @octallit \#"Int64" / { negHashLitPred ExtendedLiteralsBit } { tok_primint64 negative 3 octal } + @negative @hexadecimallit \#"Int64" / { negHashLitPred ExtendedLiteralsBit } { tok_primint64 negative 3 hexadecimal } + + @decimal \#"Int" / { ifExtension ExtendedLiteralsBit } { tok_primint positive 0 4 decimal } + @binarylit \#"Int" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint positive 2 6 binary } + @octallit \#"Int" / { ifExtension ExtendedLiteralsBit } { tok_primint positive 2 6 octal } + @hexadecimallit \#"Int" / { ifExtension ExtendedLiteralsBit } { tok_primint positive 2 6 hexadecimal } + @negative @decimal \#"Int" / { negHashLitPred ExtendedLiteralsBit } { tok_primint negative 1 5 decimal } + @negative @binarylit \#"Int" / { negHashLitPred ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primint negative 3 7 binary } + @negative @octallit \#"Int" / { negHashLitPred ExtendedLiteralsBit } { tok_primint negative 3 7 octal } + @negative @hexadecimallit \#"Int" / { negHashLitPred ExtendedLiteralsBit } { tok_primint negative 3 7 hexadecimal } + + @decimal \#"Word8" / { ifExtension ExtendedLiteralsBit } { tok_primword8 0 decimal } + @binarylit \#"Word8" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primword8 2 binary } + @octallit \#"Word8" / { ifExtension ExtendedLiteralsBit } { tok_primword8 2 octal } + @hexadecimallit \#"Word8" / { ifExtension ExtendedLiteralsBit } { tok_primword8 2 hexadecimal } + + @decimal \#"Word16" / { ifExtension ExtendedLiteralsBit } { tok_primword16 0 decimal } + @binarylit \#"Word16" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primword16 2 binary } + @octallit \#"Word16" / { ifExtension ExtendedLiteralsBit } { tok_primword16 2 octal } + @hexadecimallit \#"Word16" / { ifExtension ExtendedLiteralsBit } { tok_primword16 2 hexadecimal } + + @decimal \#"Word32" / { ifExtension ExtendedLiteralsBit } { tok_primword32 0 decimal } + @binarylit \#"Word32" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primword32 2 binary } + @octallit \#"Word32" / { ifExtension ExtendedLiteralsBit } { tok_primword32 2 octal } + @hexadecimallit \#"Word32" / { ifExtension ExtendedLiteralsBit } { tok_primword32 2 hexadecimal } + + @decimal \#"Word64" / { ifExtension ExtendedLiteralsBit } { tok_primword64 0 decimal } + @binarylit \#"Word64" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primword64 2 binary } + @octallit \#"Word64" / { ifExtension ExtendedLiteralsBit } { tok_primword64 2 octal } + @hexadecimallit \#"Word64" / { ifExtension ExtendedLiteralsBit } { tok_primword64 2 hexadecimal } + + @decimal \#"Word" / { ifExtension ExtendedLiteralsBit } { tok_primword 0 5 decimal } + @binarylit \#"Word" / { ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit } { tok_primword 2 7 binary } + @octallit \#"Word" / { ifExtension ExtendedLiteralsBit } { tok_primword 2 7 octal } + @hexadecimallit \#"Word" / { ifExtension ExtendedLiteralsBit } { tok_primword 2 7 hexadecimal } + } -- Strings and chars are lexed by hand-written code. The reason is @@ -866,6 +955,14 @@ data Token | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.SourceText" | ITprimint SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" | ITprimword SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint8 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint16 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint32 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint64 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword8 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword16 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword32 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword64 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" | ITprimfloat FractionalLit | ITprimdouble FractionalLit @@ -1281,10 +1378,10 @@ negLitPred = alexNotPred precededByClosingToken -- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token. -negHashLitPred :: AlexAccPred ExtsBitmap -negHashLitPred = prefix_minus `alexAndPred` magic_hash +negHashLitPred :: ExtBits -> AlexAccPred ExtsBitmap +negHashLitPred ext = prefix_minus `alexAndPred` magic_hash where - magic_hash = ifExtension MagicHashBit + magic_hash = ifExtension ext -- Either MagicHashBit or ExtendedLiteralsBit prefix_minus = -- Note [prefix_minus in negLitPred and negHashLitPred] alexNotPred precededByClosingToken @@ -1829,6 +1926,40 @@ binary = (2,octDecDigit) octal = (8,octDecDigit) hexadecimal = (16,hexDigit) +-- | Helper for defining @IntX@ primitive literal parsers (specifically for +-- the ExtendedLiterals extension, such as @123#Int8@). +tok_primintX :: (SourceText -> Integer -> Token) + -> Int + -> (Integer -> Integer) + -> Int + -> (Integer, (Char->Int)) -> Action +tok_primintX itint addlen transint transbuf = + tok_integral itint transint transbuf (transbuf+addlen) + +tok_primint8, tok_primint16, tok_primint32, tok_primint64 + :: (Integer -> Integer) + -> Int -> (Integer, (Char->Int)) -> Action +tok_primint8 = tok_primintX ITprimint8 5 +tok_primint16 = tok_primintX ITprimint16 6 +tok_primint32 = tok_primintX ITprimint32 6 +tok_primint64 = tok_primintX ITprimint64 6 + +-- | Helper for defining @WordX@ primitive literal parsers (specifically for +-- the ExtendedLiterals extension, such as @234#Word8@). +tok_primwordX :: (SourceText -> Integer -> Token) + -> Int + -> Int + -> (Integer, (Char->Int)) -> Action +tok_primwordX itint addlen transbuf = + tok_integral itint positive transbuf (transbuf+addlen) + +tok_primword8, tok_primword16, tok_primword32, tok_primword64 + :: Int -> (Integer, (Char->Int)) -> Action +tok_primword8 = tok_primwordX ITprimword8 6 +tok_primword16 = tok_primwordX ITprimword16 7 +tok_primword32 = tok_primwordX ITprimword32 7 +tok_primword64 = tok_primwordX ITprimword64 7 + -- readSignificandExponentPair can understand negative rationals, exponents, everything. tok_frac :: Int -> (String -> Token) -> Action tok_frac drop f span buf len _buf2 = do @@ -2903,6 +3034,7 @@ data ExtBits | NoLexicalNegationBit -- See Note [Why not LexicalNegationBit] | OverloadedRecordDotBit | OverloadedRecordUpdateBit + | ExtendedLiteralsBit -- Flags that are updated once parsing starts | InRulePragBit @@ -2982,6 +3114,7 @@ mkParserOpts extensionFlags diag_opts supported .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] .|. OverloadedRecordDotBit `xoptBit` LangExt.OverloadedRecordDot .|. OverloadedRecordUpdateBit `xoptBit` LangExt.OverloadedRecordUpdate -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information). + .|. ExtendedLiteralsBit `xoptBit` LangExt.ExtendedLiterals optBits = HaddockBit `setBitIf` isHaddock .|. RawTokenStreamBit `setBitIf` rawTokStream ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -568,7 +568,13 @@ type family XHsStringPrim x type family XHsInt x type family XHsIntPrim x type family XHsWordPrim x +type family XHsInt8Prim x +type family XHsInt16Prim x +type family XHsInt32Prim x type family XHsInt64Prim x +type family XHsWord8Prim x +type family XHsWord16Prim x +type family XHsWord32Prim x type family XHsWord64Prim x type family XHsInteger x type family XHsRat x ===================================== compiler/Language/Haskell/Syntax/Lit.hs ===================================== @@ -63,8 +63,20 @@ data HsLit x -- ^ literal @Int#@ | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer -- ^ literal @Word#@ + | HsInt8Prim (XHsInt8Prim x) {- SourceText -} Integer + -- ^ literal @Int8#@ + | HsInt16Prim (XHsInt16Prim x) {- SourceText -} Integer + -- ^ literal @Int16#@ + | HsInt32Prim (XHsInt32Prim x) {- SourceText -} Integer + -- ^ literal @Int32#@ | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer -- ^ literal @Int64#@ + | HsWord8Prim (XHsWord8Prim x) {- SourceText -} Integer + -- ^ literal @Word8#@ + | HsWord16Prim (XHsWord16Prim x) {- SourceText -} Integer + -- ^ literal @Word16#@ + | HsWord32Prim (XHsWord32Prim x) {- SourceText -} Integer + -- ^ literal @Word32#@ | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer -- ^ literal @Word64#@ | HsInteger (XHsInteger x) {- SourceText -} Integer Type @@ -149,4 +161,3 @@ instance Ord OverLitVal where compare (HsIsString _ s1) (HsIsString _ s2) = s1 `lexicalCompareFS` s2 compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT - ===================================== docs/users_guide/9.8.1-notes.rst ===================================== @@ -6,6 +6,10 @@ Version 9.8.1 Language ~~~~~~~~ +- There is a new extension :extension:`ExtendedLiterals`, which enables + sized primitive literals, e.g. ``123#Int8`` is a literal of type ``Int8#``. + See the GHC proposal `#451 `_. + Compiler ~~~~~~~~ ===================================== docs/users_guide/exts/extended_literals.rst ===================================== @@ -0,0 +1,47 @@ +.. _extended-literals: + +Sized primitive literal syntax +------------------------------ + +.. extension:: ExtendedLiterals + :shortdesc: Enable numeric literal postfix syntax for unboxed integers. + + :since: 9.8.1 + + Allows defining unboxed numeric primitive values through ``#Type`` suffixes + on numeric literals e.g. ``0xFF#Word8 :: Word8#``. + +The :extension:`MagicHash` extension enables some new literals, including ``3# +:: Int#``, ``3## :: Word#``. This does not extend to all unboxed values. For +example, there is no literal syntax for ``Word8#``: you must write something +such as ``wordToWord8 (3## :: Word#) :: Word8#``. + +:extension:`ExtendedLiterals` enables further syntax for defining primitive +numeric literals. Suffix any Haskell integer lexeme with a hash sign ``#`` +followed by a primitive numeric type (without its hash suffix) to obtain a value +of that type. For example, ``0xFF#Word8 :: Word8#``. There must be no spaces +between the parts of the literal. + +The primitive numeric types allowed are: + +- ``Int8#`` +- ``Int16#`` +- ``Int32#`` +- ``Int64#`` +- ``Int#`` +- ``Word8#`` +- ``Word16#`` +- ``Word32#`` +- ``Word64#`` +- ``Word#`` + +All types permit any nonnegative Haskell integer lexeme, e.g. ``70``, ``0x2A``, +``0o1276``, ``0b1010`` (with :extension:`BinaryLiterals`). The signed ``Int`` +types also permit negative integer lexemes. Defining a literal with a value that +can't fit in its requested type will emit an overflow warning by default, the +same as boxed numeric literals. + +As with :extension:`MagicHash`, this extension does not bring anything into +scope, nor change any semantics. The syntax only applies to numeric literals. +You may want to import ``GHC.Exts`` (see :ref:`primitives`) to refer to the +types of the literals you define. ===================================== docs/users_guide/exts/literals.rst ===================================== @@ -10,6 +10,7 @@ Literals binary_literals hex_float_literals num_decimals + extended_literals numeric_underscores overloaded_strings overloaded_labels ===================================== docs/users_guide/exts/primitives.rst ===================================== @@ -19,6 +19,9 @@ your program, you must first import ``GHC.Exts`` to bring them into scope. Many of them have names ending in ``#``, and to mention such names you need the :extension:`MagicHash` extension. +To enable defining literals for other primitive data types, see the +:extension:`ExtendedLiterals` extension. + The primops make extensive use of `unboxed types <#glasgow-unboxed>`__ and `unboxed tuples <#unboxed-tuples>`__, which we briefly summarise here. ===================================== docs/users_guide/exts/stolen_syntax.rst ===================================== @@ -80,6 +80,9 @@ The following syntax is stolen: ⟨varid⟩, ``#``\ ⟨char⟩, ``#``, ⟨string⟩, ``#``, ⟨integer⟩, ``#``, ⟨float⟩, ``#``, ⟨float⟩, ``##`` Stolen by: :extension:`MagicHash` +⟨integer⟩, ``#(Int|Word)(8|16|32|64)?`` + Stolen by: :extension:`ExtendedLiterals` + ``(#``, ``#)`` Stolen by: :extension:`UnboxedTuples` ===================================== libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs ===================================== @@ -152,6 +152,7 @@ data Extension | OverloadedRecordDot | OverloadedRecordUpdate | TypeAbstractions + | ExtendedLiterals deriving (Eq, Enum, Show, Generic, Bounded) -- 'Ord' and 'Bounded' are provided for GHC API users (see discussions -- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and ===================================== testsuite/tests/driver/T4437.hs ===================================== @@ -37,7 +37,8 @@ check title expected got -- See Note [Adding a language extension] in compiler/GHC/Driver/Session.hs. expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = - [ "TypeAbstractions" + [ "TypeAbstractions", + "ExtendedLiterals" ] expectedCabalOnlyExtensions :: [String] ===================================== testsuite/tests/extendedliterals/all.T ===================================== @@ -0,0 +1,3 @@ +test('extendedliterals01', normal, compile, ['']) +test('extendedliterals02', normal, compile, ['']) +test('extendedliterals03', [extra_ways(['ghci']), js_skip], compile_and_run, ['']) ===================================== testsuite/tests/extendedliterals/extendedliterals01.hs ===================================== @@ -0,0 +1,41 @@ +{-# LANGUAGE MagicHash, ExtendedLiterals #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} + +-- needed on 32bit +{-# OPTIONS_GHC -fno-warn-overflowed-literals #-} + +module Ex where + +import GHC.Exts +import GHC.Word +import GHC.Int + +-- Precise 'Int8#'/'Int8' range tests +exI8g1, exI8g2, exI8g3 :: Int8 +exI8g1 = I8# 0x00#Int8 +exI8g2 = I8# 0x7F#Int8 +exI8g3 = I8# -0x80#Int8 + +-- Showcase various syntax for equivalent 'Int' terms +exIg1, exIg2, exIg3 :: Int +exIg1 = 0x7FFFFFFFFFFFFFFF +exIg2 = I# 0x7FFFFFFFFFFFFFFF# +exIg3 = I# 0x7FFFFFFFFFFFFFFF#Int + +-- Motivating example: unboxed 'Word8#' parsing +data CEnum = Cons00 | Cons01 | ConsFF deriving Show +parseCEnum :: Word8# -> (# (##) | CEnum #) +parseCEnum = \case 0x00#Word8 -> (# | Cons00 #) + 0x01#Word8 -> (# | Cons01 #) + 0xFF#Word8 -> (# | ConsFF #) + _ -> (# (##) | #) + +w8ToBool# :: Word8# -> Int# +w8ToBool# = \case 0#Word8 -> 0# + _ -> 1# + +i8IsPole# :: Int8# -> Int# +i8IsPole# = \case 0x7F#Int8 -> 1# + -0x80#Int8 -> 1# + _ -> 0# ===================================== testsuite/tests/extendedliterals/extendedliterals02.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash, ExtendedLiterals #-} +{-# OPTIONS_GHC -fno-warn-overflowed-literals #-} + +module Ex where + +--import GHC.Exts +import GHC.Int + +-- Overflowed 'Int8#' literals +exI8b1, exI8b2, exI8b3, exI8b4, exI8b5 :: Int8 +exI8b1 = I8# 0x80#Int8 +exI8b2 = I8# -0x81#Int8 +exI8b3 = I8# 0xFF#Int8 +exI8b4 = I8# -0xFF#Int8 +exI8b5 = I8# 0xFFFFFFFFFFFFFFFF#Int8 ===================================== testsuite/tests/extendedliterals/extendedliterals03.hs ===================================== @@ -0,0 +1,260 @@ +{-# LANGUAGE MagicHash, ExtendedLiterals #-} +import GHC.Word +import GHC.Int +import GHC.Exts + +main = do + print (W8# (fibw8 6#Word8), + W16# (fibw16 6#Word16), + W32# (fibw32 6#Word32), + W64# (fibw64 6#Word64)) + print (I8# (fibi8 6#Int8), + I16# (fibi16 6#Int16), + I32# (fibi32 6#Int32), + I64# (fibi64 6#Int64)) + + print (W64# 0xFFFFFFFFFFFFFFFF#Word64) + print (I64# 0x7FFFFFFFFFFFFFFF#Int64) + print (I64# -0x8000000000000000#Int64) + print (W64# (x () `timesWord64#` y ())) + print (case x () `timesWord64#` y () of + 276447232#Word64 -> False + 276447233#Word64 -> False + 276447234#Word64 -> False + 276047234#Word64 -> False + 5000000004#Word64 -> False + 100000000000000#Word64 -> True + _ -> False) + print (case x () `timesWord64#` y () of + 276447232#Word64 -> True + _ -> False) + + print [ W8# (branchi8 0#Int8) + , W8# (branchi8 1#Int8) + , W8# (branchi8 -1#Int8) + , W8# (branchi8 126#Int8) + , W8# (branchi8 127#Int8) + , W8# (branchi8 -127#Int8) + , W8# (branchi8 -128#Int8) + , W8# (branchi8 2#Int8) + ] + + print [ W16# (branchi16 0#Int16) + , W16# (branchi16 1#Int16) + , W16# (branchi16 (-1#Int16)) + , W16# (branchi16 32767#Int16) + , W16# (branchi16 32766#Int16) + , W16# (branchi16 (-32768#Int16)) + , W16# (branchi16 (-32767#Int16)) + , W16# (branchi16 2#Int16) + ] + + print [ W32# (branchi32 0#Int32) + , W32# (branchi32 1#Int32) + , W32# (branchi32 (-1#Int32)) + , W32# (branchi32 2147483646#Int32) + , W32# (branchi32 2147483647#Int32) + , W32# (branchi32 (-2147483648#Int32)) + , W32# (branchi32 (-2147483647#Int32)) + , W32# (branchi32 2#Int32) + ] + + print [ W64# (branchi64 0#Int64) + , W64# (branchi64 1#Int64) + , W64# (branchi64 (-1#Int64)) + , W64# (branchi64 2147483647#Int64) + , W64# (branchi64 2147483648#Int64) + , W64# (branchi64 4294967297#Int64) + , W64# (branchi64 (-2147483648#Int64)) + , W64# (branchi64 (-2147483649#Int64)) + , W64# (branchi64 (-4294967295#Int64)) + , W64# (branchi64 9223372036854775807#Int64) + , W64# (branchi64 9223372036854775806#Int64) + , W64# (branchi64 (-9223372036854775808#Int64)) + , W64# (branchi64 (-9223372036854775807#Int64)) + , W64# (branchi64 2#Int64) + ] + + print [ I8# (branchw8 0#Word8) + , I8# (branchw8 1#Word8) + , I8# (branchw8 254#Word8) + , I8# (branchw8 255#Word8) + , I8# (branchw8 2#Word8) + ] + + print [ I16# (branchw16 0#Word16) + , I16# (branchw16 1#Word16) + , I16# (branchw16 255#Word16) + , I16# (branchw16 256#Word16) + , I16# (branchw16 65534#Word16) + , I16# (branchw16 65535#Word16) + , I16# (branchw16 2#Word16) + ] + + print [ I32# (branchw32 0#Word32) + , I32# (branchw32 1#Word32) + , I32# (branchw32 65534#Word32) + , I32# (branchw32 65535#Word32) + , I32# (branchw32 65536#Word32) + , I32# (branchw32 4294967295#Word32) + , I32# (branchw32 4294967294#Word32) + , I32# (branchw32 4294967293#Word32) + , I32# (branchw32 2#Word32) + ] + + print [ I64# (branchw64 0#Word64) + , I64# (branchw64 1#Word64) + , I64# (branchw64 65536#Word64) + , I64# (branchw64 4294967295#Word64) + , I64# (branchw64 4294967296#Word64) + , I64# (branchw64 4294967297#Word64) + , I64# (branchw64 18446744073709551615#Word64) + , I64# (branchw64 18446744073709551614#Word64) + , I64# (branchw64 18446744073709551613#Word64) + , I64# (branchw64 2#Word64) + ] + +fibw8 :: Word8# -> Word8# +fibw8 0#Word8 = 0#Word8 +fibw8 1#Word8 = 1#Word8 +fibw8 n = fibw8 (n `subWord8#` 1#Word8) `plusWord8#` fibw8 (n `subWord8#` 2#Word8) + +fibw16 :: Word16# -> Word16# +fibw16 0#Word16 = 0#Word16 +fibw16 1#Word16 = 1#Word16 +fibw16 n = fibw16 (n `subWord16#` 1#Word16) `plusWord16#` fibw16 (n `subWord16#` 2#Word16) + +fibw32 :: Word32# -> Word32# +fibw32 0#Word32 = 0#Word32 +fibw32 1#Word32 = 1#Word32 +fibw32 n = fibw32 (n `subWord32#` 1#Word32) `plusWord32#` fibw32 (n `subWord32#` 2#Word32) + +fibw64 :: Word64# -> Word64# +fibw64 0#Word64 = 0#Word64 +fibw64 1#Word64 = 1#Word64 +fibw64 n = fibw64 (n `subWord64#` 1#Word64) `plusWord64#` fibw64 (n `subWord64#` 2#Word64) + +-- + +fibi8 :: Int8# -> Int8# +fibi8 0#Int8 = 0#Int8 +fibi8 1#Int8 = 1#Int8 +fibi8 n = fibi8 (n `subInt8#` 1#Int8) `plusInt8#` fibi8 (n `subInt8#` 2#Int8) + +fibi16 :: Int16# -> Int16# +fibi16 0#Int16 = 0#Int16 +fibi16 1#Int16 = 1#Int16 +fibi16 n = fibi16 (n `subInt16#` 1#Int16) `plusInt16#` fibi16 (n `subInt16#` 2#Int16) + +fibi32 :: Int32# -> Int32# +fibi32 0#Int32 = 0#Int32 +fibi32 1#Int32 = 1#Int32 +fibi32 n = fibi32 (n `subInt32#` 1#Int32) `plusInt32#` fibi32 (n `subInt32#` 2#Int32) + +fibi64 :: Int64# -> Int64# +fibi64 0#Int64 = 0#Int64 +fibi64 1#Int64 = 1#Int64 +fibi64 n = fibi64 (n `subInt64#` 1#Int64) `plusInt64#` fibi64 (n `subInt64#` 2#Int64) + +-- + +branchi8 :: Int8# -> Word8# +branchi8 0#Int8 = 1#Word8 +branchi8 1#Int8 = 2#Word8 +branchi8 (-1#Int8) = 3#Word8 +branchi8 126#Int8 = 4#Word8 +branchi8 127#Int8 = 5#Word8 +branchi8 (-127#Int8) = 6#Word8 +branchi8 (-128#Int8) = 7#Word8 +branchi8 _ = 0#Word8 +{-# NOINLINE branchi8 #-} + +branchi16 :: Int16# -> Word16# +branchi16 0#Int16 = 1#Word16 +branchi16 1#Int16 = 2#Word16 +branchi16 (-1#Int16) = 3#Word16 +branchi16 32767#Int16 = 255#Word16 +branchi16 32766#Int16 = 256#Word16 +branchi16 (-32768#Int16) = 65534#Word16 +branchi16 (-32767#Int16) = 65535#Word16 +branchi16 _ = 0#Word16 +{-# NOINLINE branchi16 #-} + +branchi32 :: Int32# -> Word32# +branchi32 0#Int32 = 1#Word32 +branchi32 1#Int32 = 2#Word32 +branchi32 (-1#Int32) = 3#Word32 +branchi32 2147483646#Int32 = 65535#Word32 +branchi32 2147483647#Int32 = 65536#Word32 +branchi32 (-2147483648#Int32) = 4294967294#Word32 +branchi32 (-2147483647#Int32) = 4294967295#Word32 +branchi32 _ = 0#Word32 +{-# NOINLINE branchi32 #-} + +branchi64 :: Int64# -> Word64# +branchi64 0#Int64 = 18446744073709551615#Word64 +branchi64 1#Int64 = 2147483648#Word64 +branchi64 (-1#Int64) = 4294967296#Word64 +branchi64 2147483647#Int64 = 4294967297#Word64 +branchi64 2147483648#Int64 = 9#Word64 +branchi64 4294967297#Int64 = 1#Word64 +branchi64 (-2147483648#Int64) = 18446744073709551614#Word64 +branchi64 (-2147483649#Int64) = 3#Word64 +branchi64 (-4294967295#Int64) = 4#Word64 +branchi64 9223372036854775807#Int64 = 5#Word64 +branchi64 9223372036854775806#Int64 = 6#Word64 +branchi64 (-9223372036854775808#Int64) = 7#Word64 +branchi64 (-9223372036854775807#Int64) = 8#Word64 +branchi64 _ = 0#Word64 +{-# NOINLINE branchi64 #-} + +branchw8 :: Word8# -> Int8# +branchw8 0#Word8 = 1#Int8 +branchw8 1#Word8 = (-1#Int8) +branchw8 254#Word8 = 2#Int8 +branchw8 255#Word8 = (-2#Int8) +branchw8 _ = 0#Int8 +{-# NOINLINE branchw8 #-} + +branchw16 :: Word16# -> Int16# +branchw16 0#Word16 = 256#Int16 +branchw16 1#Word16 = (-256#Int16) +branchw16 255#Word16 = 32767#Int16 +branchw16 256#Word16 = (-32768#Int16) +branchw16 65534#Word16 = (-1#Int16) +branchw16 65535#Word16 = 1#Int16 +branchw16 _ = 0#Int16 +{-# NOINLINE branchw16 #-} + +branchw32 :: Word32# -> Int32# +branchw32 0#Word32 = 2147483647#Int32 +branchw32 1#Word32 = (-2147483648#Int32) +branchw32 65534#Word32 = 65535#Int32 +branchw32 65535#Word32 = 65536#Int32 +branchw32 65536#Word32 = (-1#Int32) +branchw32 4294967295#Word32 = (-65536#Int32) +branchw32 4294967294#Word32 = (-65537#Int32) +branchw32 4294967293#Word32 = 1#Int32 +branchw32 _ = 0#Int32 +{-# NOINLINE branchw32 #-} + +branchw64 :: Word64# -> Int64# +branchw64 0#Word64 = 9223372036854775807#Int64 +branchw64 1#Word64 = 2147483648#Int64 +branchw64 65536#Word64 = 4294967296#Int64 +branchw64 4294967295#Word64 = 4294967297#Int64 +branchw64 4294967296#Word64 = (-1#Int64) +branchw64 4294967297#Word64 = 9223372036854775806#Int64 +branchw64 18446744073709551615#Word64 = (-9223372036854775808#Int64) +branchw64 18446744073709551614#Word64 = (-9223372036854775807#Int64) +branchw64 18446744073709551613#Word64 = 1#Int64 +branchw64 _ = 0#Int64 +{-# NOINLINE branchw64 #-} + +x :: () -> Word64# +x () = 2000000000#Word64 +{-# NOINLINE x #-} + +y :: () -> Word64# +y () = 50000#Word64 +{-# NOINLINE y #-} ===================================== testsuite/tests/extendedliterals/extendedliterals03.stdout ===================================== @@ -0,0 +1,16 @@ +(8,8,8,8) +(8,8,8,8) +18446744073709551615 +9223372036854775807 +-9223372036854775808 +100000000000000 +True +False +[1,2,3,4,5,6,7,0] +[1,2,3,255,256,65534,65535,0] +[1,2,3,65535,65536,4294967294,4294967295,0] +[18446744073709551615,2147483648,4294967296,4294967297,9,1,18446744073709551614,3,4,5,6,7,8,0] +[1,-1,2,-2,0] +[256,-256,32767,-32768,-1,1,0] +[2147483647,-2147483648,65535,65536,-1,-65536,-65537,1,0] +[9223372036854775807,2147483648,4294967296,4294967297,-1,9223372036854775806,-9223372036854775808,-9223372036854775807,1,0] ===================================== testsuite/tests/ghci/should_run/SizedLiterals.hs deleted ===================================== @@ -1,117 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -import SizedLiteralsA -import Language.Haskell.TH - -{- - - This file is compiled with the GHC flags: - - -O -fbyte-code-and-object-code -fprefer-byte-code - - This makes sure that the Template Haskell runs in the bytecode - interpreter with optimized bytecode, allowing us to test the - sized unboxed literals. - - Running the test in GHCi directly would disable optimization. - - -} - -main :: IO () -main = do - print $(pure $ ListE [ ie (fibw8 5) - , ie (fibw16 5) - , ie (fibw32 5) - , ie (fibw64 5) - ]) - - print $(pure $ ListE [ ie (fibi8 5) - , ie (fibi16 5) - , ie (fibi32 5) - , ie (fibi64 5) - ]) - - print $(pure $ ListE [ ie (branchi8 0) - , ie (branchi8 1) - , ie (branchi8 (-1)) - , ie (branchi8 126) - , ie (branchi8 127) - , ie (branchi8 (-127)) - , ie (branchi8 (-128)) - , ie (branchi8 2) - ]) - - print $(pure $ ListE [ ie (branchi16 0) - , ie (branchi16 1) - , ie (branchi16 (-1)) - , ie (branchi16 32767) - , ie (branchi16 32766) - , ie (branchi16 (-32768)) - , ie (branchi16 (-32767)) - , ie (branchi16 2) - ]) - - print $(pure $ ListE [ ie (branchi32 0) - , ie (branchi32 1) - , ie (branchi32 (-1)) - , ie (branchi32 2147483646) - , ie (branchi32 2147483647) - , ie (branchi32 (-2147483648)) - , ie (branchi32 (-2147483647)) - , ie (branchi32 2) - ]) - - print $(pure $ ListE [ ie (branchi64 0) - , ie (branchi64 1) - , ie (branchi64 (-1)) - , ie (branchi64 2147483647) - , ie (branchi64 2147483648) - , ie (branchi64 4294967297) - , ie (branchi64 (-2147483648)) - , ie (branchi64 (-2147483649)) - , ie (branchi64 (-4294967295)) - , ie (branchi64 9223372036854775807) - , ie (branchi64 9223372036854775806) - , ie (branchi64 (-9223372036854775808)) - , ie (branchi64 (-9223372036854775807)) - , ie (branchi64 2) - ]) - - print $(pure $ ListE [ ie (branchw8 0) - , ie (branchw8 1) - , ie (branchw8 254) - , ie (branchw8 255) - , ie (branchw8 2) - ]) - - print $(pure $ ListE [ ie (branchw16 0) - , ie (branchw16 1) - , ie (branchw16 255) - , ie (branchw16 256) - , ie (branchw16 65534) - , ie (branchw16 65535) - , ie (branchw16 2) - ]) - - print $(pure $ ListE [ ie (branchw32 0) - , ie (branchw32 1) - , ie (branchw32 65534) - , ie (branchw32 65535) - , ie (branchw32 65536) - , ie (branchw32 4294967295) - , ie (branchw32 4294967294) - , ie (branchw32 4294967293) - , ie (branchw32 2) - ]) - - print $(pure $ ListE [ ie (branchw64 0) - , ie (branchw64 1) - , ie (branchw64 65536) - , ie (branchw64 4294967295) - , ie (branchw64 4294967296) - , ie (branchw64 4294967297) - , ie (branchw64 18446744073709551615) - , ie (branchw64 18446744073709551614) - , ie (branchw64 18446744073709551613) - , ie (branchw64 2) - ]) \ No newline at end of file ===================================== testsuite/tests/ghci/should_run/SizedLiteralsA.hs deleted ===================================== @@ -1,139 +0,0 @@ -module SizedLiteralsA where - -import GHC.Word -import GHC.Int -import Language.Haskell.TH.Syntax - -fibw8 :: Word8 -> Word8 -fibw8 0 = 0 -fibw8 1 = 1 -fibw8 n = fibw8 (n-1) + fibw8 (n-2) - -fibw16 :: Word16 -> Word16 -fibw16 0 = 0 -fibw16 1 = 1 -fibw16 n = fibw16 (n-1) + fibw16 (n-2) - -fibw32 :: Word32 -> Word32 -fibw32 0 = 0 -fibw32 1 = 1 -fibw32 n = fibw32 (n-1) + fibw32 (n-2) - -fibw64 :: Word64 -> Word64 -fibw64 0 = 0 -fibw64 1 = 1 -fibw64 n = fibw64 (n-1) + fibw64 (n-2) - --- - -fibi8 :: Int8 -> Int8 -fibi8 0 = 0 -fibi8 1 = 1 -fibi8 n = fibi8 (n-1) + fibi8 (n-2) - -fibi16 :: Int16 -> Int16 -fibi16 0 = 0 -fibi16 1 = 1 -fibi16 n = fibi16 (n-1) + fibi16 (n-2) - -fibi32 :: Int32 -> Int32 -fibi32 0 = 0 -fibi32 1 = 1 -fibi32 n = fibi32 (n-1) + fibi32 (n-2) - -fibi64 :: Int64 -> Int64 -fibi64 0 = 0 -fibi64 1 = 1 -fibi64 n = fibi64 (n-1) + fibi64 (n-2) - --- - -branchi8 :: Int8 -> Word8 -branchi8 0 = 1 -branchi8 1 = 2 -branchi8 (-1) = 3 -branchi8 126 = 4 -branchi8 127 = 5 -branchi8 (-127) = 6 -branchi8 (-128) = 7 -branchi8 _ = 0 - -branchi16 :: Int16 -> Word16 -branchi16 0 = 1 -branchi16 1 = 2 -branchi16 (-1) = 3 -branchi16 32767 = 255 -branchi16 32766 = 256 -branchi16 (-32768) = 65534 -branchi16 (-32767) = 65535 -branchi16 _ = 0 - -branchi32 :: Int32 -> Word32 -branchi32 0 = 1 -branchi32 1 = 2 -branchi32 (-1) = 3 -branchi32 2147483646 = 65535 -branchi32 2147483647 = 65536 -branchi32 (-2147483648) = 4294967294 -branchi32 (-2147483647) = 4294967295 -branchi32 _ = 0 - -branchi64 :: Int64 -> Word64 -branchi64 0 = 18446744073709551615 -branchi64 1 = 2147483648 -branchi64 (-1) = 4294967296 -branchi64 2147483647 = 4294967297 -branchi64 2147483648 = 9 -branchi64 4294967297 = 1 -branchi64 (-2147483648) = 18446744073709551614 -branchi64 (-2147483649) = 3 -branchi64 (-4294967295) = 4 -branchi64 9223372036854775807 = 5 -branchi64 9223372036854775806 = 6 -branchi64 (-9223372036854775808) = 7 -branchi64 (-9223372036854775807) = 8 -branchi64 _ = 0 - -branchw8 :: Word8 -> Int8 -branchw8 0 = 1 -branchw8 1 = (-1) -branchw8 254 = 2 -branchw8 255 = (-2) -branchw8 _ = 0 - -branchw16 :: Word16 -> Int16 -branchw16 0 = 256 -branchw16 1 = (-256) -branchw16 255 = 32767 -branchw16 256 = (-32768) -branchw16 65534 = (-1) -branchw16 65535 = 1 -branchw16 _ = 0 - -branchw32 :: Word32 -> Int32 -branchw32 0 = 2147483647 -branchw32 1 = (-2147483648) -branchw32 65534 = 65535 -branchw32 65535 = 65536 -branchw32 65536 = (-1) -branchw32 4294967295 = (-65536) -branchw32 4294967294 = (-65537) -branchw32 4294967293 = 1 -branchw32 _ = 0 - -branchw64 :: Word64 -> Int64 -branchw64 0 = 9223372036854775807 -branchw64 1 = 2147483648 -branchw64 65536 = 4294967296 -branchw64 4294967295 = 4294967297 -branchw64 4294967296 = (-1) -branchw64 4294967297 = 9223372036854775806 -branchw64 18446744073709551615 = (-9223372036854775808) -branchw64 18446744073709551614 = (-9223372036854775807) -branchw64 18446744073709551613 = 1 -branchw64 _ = 0 - --- - -ie :: Integral a => a -> Exp -ie x = LitE (IntegerL (toInteger x)) ===================================== testsuite/tests/ghci/should_run/all.T ===================================== @@ -85,7 +85,6 @@ test('T19628', [extra_files(['T19628a.hs']), only_ways(['ghci']) ], compile_and_ test('T21052', just_ghci, ghci_script, ['T21052.script']) test('T21300', just_ghci, ghci_script, ['T21300.script']) test('UnliftedDataType2', just_ghci, compile_and_run, ['']) -test('SizedLiterals', [req_interp, extra_files(["SizedLiteralsA.hs"]),extra_hc_opts("-O -fbyte-code-and-object-code -fprefer-byte-code")], compile_and_run, ['']) test('T22829', just_ghci + [extra_hc_opts("-Wmissing-import-lists -Werror")], compile_and_run, ['']) test('T23229', just_ghci + [extra_hc_opts("-this-unit-id my-package -Wno-missing-methods T23229")], ghci_script, ['T23229.script']) ===================================== testsuite/tests/printer/Ppr038.hs ===================================== @@ -21,6 +21,14 @@ blah = x wordH = 005## floatH = 3.20# doubleH = 04.16## - -- int64H = 00456L# - -- word64H = 00456L## + intNH = 1000#Int + int8H = 1008#Int8 + int16H = 1016#Int8 + int32H = 1032#Int32 + int64H = 1064#Int64 + wordNH = 2000#Word + word8H = 2008#Word8 + word16H = 2016#Word16 + word32H = 2032#Word32 + word64H = 2064#Word64 x = 1 ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -4695,7 +4695,13 @@ hsLit2String lit = HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" HsIntPrim src v -> toSourceTextWithSuffix src v "" HsWordPrim src v -> toSourceTextWithSuffix src v "" + HsInt8Prim src v -> toSourceTextWithSuffix src v "" + HsInt16Prim src v -> toSourceTextWithSuffix src v "" + HsInt32Prim src v -> toSourceTextWithSuffix src v "" HsInt64Prim src v -> toSourceTextWithSuffix src v "" + HsWord8Prim src v -> toSourceTextWithSuffix src v "" + HsWord16Prim src v -> toSourceTextWithSuffix src v "" + HsWord32Prim src v -> toSourceTextWithSuffix src v "" HsWord64Prim src v -> toSourceTextWithSuffix src v "" HsInteger src v _ -> toSourceTextWithSuffix src v "" HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl "" ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit 03ba53ca764f56a13d12607c110f923f129e809a +Subproject commit e16e20d592a6f5d9ed1af17b77fafd6495242345 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/931c8d82f28fb98a7e0ad0a837eff05c08021cbe -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/931c8d82f28fb98a7e0ad0a837eff05c08021cbe You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 00:17:13 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 May 2023 20:17:13 -0400 Subject: [Git][ghc/ghc][master] Document instances of Double Message-ID: <6452f9895a5bd_e3e0651f0445672@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 2 changed files: - libraries/base/GHC/Float.hs - libraries/base/GHC/Real.hs Changes: ===================================== libraries/base/GHC/Float.hs ===================================== @@ -276,17 +276,18 @@ class (RealFrac a, Floating a) => RealFloat a where ------------------------------------------------------------------------ -- | @since 2.01 --- Note that due to the presence of @NaN@, not all elements of 'Float' have an --- additive inverse. -- --- >>> 0/0 + (negate 0/0 :: Float) --- NaN +-- This instance implements IEEE 754 standard with all its usual pitfalls +-- about NaN, infinities and negative zero. +-- Neither addition not multiplication are associative or distributive: -- --- Also note that due to the presence of -0, `Float`'s 'Num' instance doesn't --- have an additive identity +-- >>> (0.1 + 0.1 :: Float) + 0.5 == 0.1 + (0.1 + 0.5) +-- False +-- >>> (0.1 + 0.2 :: Float) * 0.9 == 0.1 * 0.9 + 0.2 * 0.9 +-- False +-- >>> (0.1 * 0.1 :: Float) * 0.9 == 0.1 * (0.1 * 0.9) +-- False -- --- >>> 0 + (-0 :: Float) --- 0.0 instance Num Float where (+) x y = plusFloat x y (-) x y = minusFloat x y @@ -317,6 +318,14 @@ naturalToFloat# (NB b) = case integerToBinaryFloat' (IP b) of F# x -> x -- | @since 2.01 +-- +-- Beware that 'toRational' generates garbage for non-finite arguments: +-- +-- >>> toRational (1/0 :: Float) +-- 340282366920938463463374607431768211456 % 1 +-- >>> toRational (0/0 :: Float) +-- 510423550381407695195061911147652317184 % 1 +-- instance Real Float where toRational (F# x#) = case decodeFloat_Int# x# of @@ -330,14 +339,19 @@ instance Real Float where IS m# :% integerShiftL# 1 (int2Word# (negateInt# e#)) -- | @since 2.01 --- Note that due to the presence of @NaN@, not all elements of 'Float' have an --- multiplicative inverse. -- --- >>> 0/0 * (recip 0/0 :: Float) --- NaN +-- This instance implements IEEE 754 standard with all its usual pitfalls +-- about NaN, infinities and negative zero. +-- +-- >>> 0 == (-0 :: Float) +-- True +-- >>> recip 0 == recip (-0 :: Float) +-- False +-- >>> map (/ 0) [-1, 0, 1 :: Float] +-- [-Infinity,NaN,Infinity] +-- >>> map (* 0) $ map (/ 0) [-1, 0, 1 :: Float] +-- [NaN,NaN,NaN] -- --- Additionally, because of @NaN@ this instance does not obey the left-inverse --- law for 'toRational'/'fromRational'. instance Fractional Float where (/) x y = divideFloat x y {-# INLINE fromRational #-} @@ -360,6 +374,15 @@ rationalToFloat n d mantDigs = FLT_MANT_DIG -- | @since 2.01 +-- +-- Beware that results for non-finite arguments are garbage: +-- +-- >>> [ f x | f <- [round, floor, ceiling], x <- [-1/0, 0/0, 1/0 :: Float] ] :: [Int] +-- [0,0,0,0,0,0,0,0,0] +-- >>> map properFraction [-1/0, 0/0, 1/0] :: [(Int, Float)] +-- [(0,0.0),(0,0.0),(0,0.0)] +-- +-- and get even more non-sensical if you ask for 'Integer' instead of 'Int'. instance RealFrac Float where properFraction = properFractionFloat @@ -507,17 +530,18 @@ instance Show Float where ------------------------------------------------------------------------ -- | @since 2.01 --- Note that due to the presence of @NaN@, not all elements of 'Double' have an --- additive inverse. -- --- >>> 0/0 + (negate 0/0 :: Double) --- NaN +-- This instance implements IEEE 754 standard with all its usual pitfalls +-- about NaN, infinities and negative zero. +-- Neither addition not multiplication are associative or distributive: -- --- Also note that due to the presence of -0, `Double`'s 'Num' instance doesn't --- have an additive identity +-- >>> (0.1 + 0.1) + 0.4 == 0.1 + (0.1 + 0.4) +-- False +-- >>> (0.1 + 0.2) * 0.3 == 0.1 * 0.3 + 0.2 * 0.3 +-- False +-- >>> (0.1 * 0.1) * 0.3 == 0.1 * (0.1 * 0.3) +-- False -- --- >>> 0 + (-0 :: Double) --- 0.0 instance Num Double where (+) x y = plusDouble x y (-) x y = minusDouble x y @@ -550,6 +574,14 @@ naturalToDouble# (NB b) = case integerToBinaryFloat' (IP b) of -- | @since 2.01 +-- +-- Beware that 'toRational' generates garbage for non-finite arguments: +-- +-- >>> toRational (1/0) +-- 179769313 (and 300 more digits...) % 1 +-- >>> toRational (0/0) +-- 269653970 (and 300 more digits...) % 1 +-- instance Real Double where toRational (D# x#) = case integerDecodeDouble# x# of @@ -563,14 +595,19 @@ instance Real Double where m :% integerShiftL# 1 (int2Word# (negateInt# e#)) -- | @since 2.01 --- Note that due to the presence of @NaN@, not all elements of 'Double' have an --- multiplicative inverse. -- --- >>> 0/0 * (recip 0/0 :: Double) --- NaN +-- This instance implements IEEE 754 standard with all its usual pitfalls +-- about NaN, infinities and negative zero. +-- +-- >>> 0 == (-0 :: Double) +-- True +-- >>> recip 0 == recip (-0 :: Double) +-- False +-- >>> map (/ 0) [-1, 0, 1] +-- [-Infinity,NaN,Infinity] +-- >>> map (* 0) $ map (/ 0) [-1, 0, 1] +-- [NaN,NaN,NaN] -- --- Additionally, because of @NaN@ this instance does not obey the left-inverse --- law for 'toRational'/'fromRational'. instance Fractional Double where (/) x y = divideDouble x y {-# INLINE fromRational #-} @@ -626,6 +663,15 @@ instance Floating Double where {-# INLINE log1pexp #-} -- | @since 2.01 +-- +-- Beware that results for non-finite arguments are garbage: +-- +-- >>> [ f x | f <- [round, floor, ceiling], x <- [-1/0, 0/0, 1/0] ] :: [Int] +-- [0,0,0,0,0,0,0,0,0] +-- >>> map properFraction [-1/0, 0/0, 1/0] :: [(Int, Double)] +-- [(0,0.0),(0,0.0),(0,0.0)] +-- +-- and get even more non-sensical if you ask for 'Integer' instead of 'Int'. instance RealFrac Double where properFraction = properFractionDouble truncate = truncateDouble @@ -796,6 +842,14 @@ for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.) -} -- | @since 2.01 +-- +-- 'fromEnum' just truncates its argument, beware of all sorts of overflows. +-- +-- List generators have extremely peculiar behavior, mandated by +-- [Haskell Report 2010](https://www.haskell.org/onlinereport/haskell2010/haskellch6.html#x13-1310006.3.4): +-- +-- >>> [0..1.5 :: Float] +-- [0.0,1.0,2.0] instance Enum Float where succ x = x + 1 pred x = x - 1 @@ -807,6 +861,14 @@ instance Enum Float where enumFromThenTo = numericEnumFromThenTo -- | @since 2.01 +-- +-- 'fromEnum' just truncates its argument, beware of all sorts of overflows. +-- +-- List generators have extremely peculiar behavior, mandated by +-- [Haskell Report 2010](https://www.haskell.org/onlinereport/haskell2010/haskellch6.html#x13-1310006.3.4): +-- +-- >>> [0..1.5] +-- [0.0,1.0,2.0] instance Enum Double where succ x = x + 1 pred x = x - 1 ===================================== libraries/base/GHC/Real.hs ===================================== @@ -142,6 +142,10 @@ denominator (_ :% y) = y -- -- [__Coherence with 'fromRational'__]: if the type also implements 'Fractional', -- then 'fromRational' is a left inverse for 'toRational', i.e. @fromRational (toRational i) = i@ +-- +-- The law does not hold for 'Float', 'Double', 'Foreign.C.Types.CFloat', +-- 'Foreign.C.Types.CDouble', etc., because these types contain non-finite values, +-- which cannot be roundtripped through 'Rational'. class (Num a, Ord a) => Real a where -- | the rational equivalent of its real argument with full precision toRational :: a -> Rational View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f3460845cdd37cf5a086cc02336c35310246b725 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f3460845cdd37cf5a086cc02336c35310246b725 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 00:17:53 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 May 2023 20:17:53 -0400 Subject: [Git][ghc/ghc][master] Bump Cabal submodule (#22356) Message-ID: <6452f9b130763_e3e0651e6448763@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 1 changed file: - libraries/Cabal Changes: ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit 280a7a71e495da8f25ae33dbc6e743526b9106f9 +Subproject commit 4bfd6a0352ecfd71e1ca756a007ca827b68416d5 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e9caa1a54e149a71af2555336531425f64521af -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e9caa1a54e149a71af2555336531425f64521af You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 00:18:34 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 May 2023 20:18:34 -0400 Subject: [Git][ghc/ghc][master] Don't forget to check the parent in an export list Message-ID: <6452f9dac76e4_e3e062c1c4cc5403c@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 4 changed files: - compiler/GHC/Tc/Gen/Export.hs - + testsuite/tests/rename/should_compile/T23318.hs - + testsuite/tests/rename/should_compile/T23318.stderr - testsuite/tests/rename/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -356,55 +356,51 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie occs ie@(IEThingAll ann n') = do - (n, kids) <- lookup_ie_all ie n' - let name = unLoc n + (par, kids) <- lookup_ie_all ie n' + let name = greName par avails = map greName kids - occs' <- check_occs occs ie kids + occs' <- check_occs occs ie (par:kids) return $ Just ( occs' - , IEThingAll ann (replaceLWrappedName n' (unLoc n)) + , IEThingAll ann (replaceLWrappedName n' name) , AvailTC name (name:avails)) lookup_ie occs ie@(IEThingWith ann l wc sub_rdrs) = do - (lname, subs, with_gres) + (par_gre, subs, with_gres) <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs - (_, wc_gres) <- + wc_gres <- case wc of - NoIEWildcard -> return (lname, []) - IEWildcard _ -> lookup_ie_all ie l + NoIEWildcard -> return [] + IEWildcard _ -> snd <$> lookup_ie_all ie l - let name = unLoc lname - all_names = name : map greName (with_gres ++ wc_gres) - gres = localVanillaGRE NoParent name - -- localVanillaGRE might not be correct here, - -- but these GREs are only passed to check_occs - -- which only needs the correct Name for the GREs... - : with_gres ++ wc_gres + let par = greName par_gre + all_names = par : map greName (with_gres ++ wc_gres) + gres = par_gre : with_gres ++ wc_gres occs' <- check_occs occs ie gres return $ Just $ ( occs' - , IEThingWith ann (replaceLWrappedName l name) wc subs - , AvailTC name all_names) + , IEThingWith ann (replaceLWrappedName l par) wc subs + , AvailTC par all_names) lookup_ie _ _ = panic "lookup_ie" -- Other cases covered earlier lookup_ie_with :: LIEWrappedName GhcPs -> [LIEWrappedName GhcPs] - -> RnM (Located Name, [LIEWrappedName GhcRn], [GlobalRdrElt]) - lookup_ie_with (L l rdr) sub_rdrs = + -> RnM (GlobalRdrElt, [LIEWrappedName GhcRn], [GlobalRdrElt]) + lookup_ie_with (L _ rdr) sub_rdrs = do { gre <- lookupGlobalOccRn $ ieWrappedName rdr ; let name = greName gre ; kids <- lookupChildrenExport name sub_rdrs ; if isUnboundName name - then return (L (locA l) name, [], [gre]) - else return (L (locA l) name, map fst kids, map snd kids) } + then return (gre, [], [gre]) + else return (gre, map fst kids, map snd kids) } lookup_ie_all :: IE GhcPs -> LIEWrappedName GhcPs - -> RnM (Located Name, [GlobalRdrElt]) - lookup_ie_all ie (L l rdr) = + -> RnM (GlobalRdrElt, [GlobalRdrElt]) + lookup_ie_all ie (L _ rdr) = do { gre <- lookupGlobalOccRn $ ieWrappedName rdr ; let name = greName gre gres = findChildren kids_env name @@ -415,7 +411,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (TcRnExportHiddenComponents ie) - ; return (L (locA l) name, gres) } + ; return (gre, gres) } ------------- lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn)) @@ -663,8 +659,9 @@ checkPatSynParent parent NoParent gre {-===========================================================================-} --- | Check that the each of the given 'GlobalRdrElt's does not appear multiple --- times in the 'ExportOccMap', as per Note [Exporting duplicate declarations]. +-- | Insert the given 'GlobalRdrElt's into the 'ExportOccMap', checking that +-- each of the given 'GlobalRdrElt's does not appear multiple times in +-- the 'ExportOccMap', as per Note [Exporting duplicate declarations]. check_occs :: ExportOccMap -> IE GhcPs -> [GlobalRdrElt] -> RnM ExportOccMap check_occs occs ie gres -- 'gres' are the entities specified by 'ie' ===================================== testsuite/tests/rename/should_compile/T23318.hs ===================================== @@ -0,0 +1,2 @@ +module T23318 (T(), T(..)) where +data T = A | B ===================================== testsuite/tests/rename/should_compile/T23318.stderr ===================================== @@ -0,0 +1,3 @@ + +T23318.hs:1:21: warning: [GHC-47854] [-Wduplicate-exports (in -Wdefault)] + ‘T’ is exported by ‘T(..)’ and ‘T()’ ===================================== testsuite/tests/rename/should_compile/all.T ===================================== @@ -210,3 +210,4 @@ test('GHCINullaryRecordWildcard', combined_output, ghci_script, ['GHCINullaryRec test('GHCIImplicitImportNullaryRecordWildcard', combined_output, ghci_script, ['GHCIImplicitImportNullaryRecordWildcard.script']) test('T22122', [expect_broken(22122), extra_files(['T22122_aux.hs'])], multimod_compile, ['T22122', '-v0']) test('T23240', [req_th, extra_files(['T23240_aux.hs'])], multimod_compile, ['T23240', '-v0']) +test('T23318', normal, compile, ['-Wduplicate-exports']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4eafb52a26ad07b2be0af71a6896fb01ed919614 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4eafb52a26ad07b2be0af71a6896fb01ed919614 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 00:19:11 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 May 2023 20:19:11 -0400 Subject: [Git][ghc/ghc][master] Fix unlit path in cross bindists Message-ID: <6452f9ff64289_e3e0651ef0575bf@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 1 changed file: - hadrian/bindist/Makefile Changes: ===================================== hadrian/bindist/Makefile ===================================== @@ -106,7 +106,7 @@ lib/settings : config.mk @echo ',("touch command", "$(SettingsTouchCommand)")' >> $@ @echo ',("dllwrap command", "$(SettingsDllWrapCommand)")' >> $@ @echo ',("windres command", "$(SettingsWindresCommand)")' >> $@ - @echo ',("unlit command", "$$topdir/bin/unlit")' >> $@ + @echo ',("unlit command", "$$topdir/bin/$(CrossCompilePrefix)unlit")' >> $@ @echo ',("cross compiling", "$(CrossCompiling)")' >> $@ @echo ',("target platform string", "$(TARGETPLATFORM)")' >> $@ @echo ',("target os", "$(HaskellTargetOs)")' >> $@ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fde4ac84ec7b1ead238cb158bbef48555d12af9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fde4ac84ec7b1ead238cb158bbef48555d12af9 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 02:06:48 2023 From: gitlab at gitlab.haskell.org (Ryan Scott (@RyanGlScott)) Date: Wed, 03 May 2023 22:06:48 -0400 Subject: [Git][ghc/ghc][wip/T23329] Fix type variable substitution in gen_Newtype_fam_insts Message-ID: <64531338dd66e_e3e063c08c8c605a@gitlab.mail> Ryan Scott pushed to branch wip/T23329 at Glasgow Haskell Compiler / GHC Commits: 78a7d47b by Ryan Scott at 2023-05-03T22:05:13-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 5 changed files: - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/TyCl/Class.hs - + testsuite/tests/deriving/should_compile/T23329.hs - + testsuite/tests/deriving/should_compile/T23329_M.hs - testsuite/tests/deriving/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -46,6 +46,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate( newFamInst ) import GHC.Tc.Utils.Env @@ -2100,8 +2101,8 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty newFamInst SynFamilyInst axiom where fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs + (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs + (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -22,6 +22,7 @@ module GHC.Tc.TyCl.Class , instDeclCtxt2 , instDeclCtxt3 , tcATDefault + , substATBndrs ) where @@ -42,7 +43,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad import GHC.Tc.TyCl.Build( TcMethInfo ) -import GHC.Core.Type ( piResultTys ) +import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Core.Class @@ -58,7 +59,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var -import GHC.Types.Var.Env +import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) import GHC.Types.SrcLoc import GHC.Types.Basic @@ -501,8 +502,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) -- instance C [x] -- Then we want to generate the decl: type F [x] b = () | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) + = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc) rhs' = substTyUnchecked subst' rhs_ty tcv' = tyCoVarsOfTypesList pat_tys' (tv', cv') = partition isTyVar tcv' @@ -525,14 +525,73 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) | otherwise -- defs = Nothing = do { warnMissingAT (tyConName fam_tc) ; return [] } + +-- | Apply a substitution to the type variable binders of an associated type +-- family. This is used to compute default instances for associated type +-- families (see 'tcATDefault') as well as @newtype at -derived associated type +-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate"). +-- +-- As a concrete example, consider the following class and associated type +-- family: +-- +-- @ +-- class C k (a :: k) where +-- type F k a (b :: k) :: Type +-- type F j p q = (Proxy @j p, Proxy @j (q :: j)) +-- @ +-- +-- If a user defines this instance: +-- +-- @ +-- instance C (Type -> Type) Maybe where {} +-- @ +-- +-- Then in order to typecheck the default @F@ instance, we must apply the +-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which +-- are @[k, a, (b :: k)]@. The result should look like this: +-- +-- @ +-- type F (Type -> Type) Maybe (b :: Type -> Type) = +-- (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type)) +-- @ +-- +-- Making this work requires some care. There are two cases: +-- +-- 1. If we encounter a type variable in the domain of the substitution (e.g., +-- @k@ or @a@), then we apply the substitution directly. +-- +-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn +-- @b :: k@ to @b :: Type -> Type@). We then return an extended substitution +-- where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@). +-- +-- This step is important to do in case there are later occurrences of @b@, +-- which we must ensure have the correct kind. Otherwise, we might end up +-- with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the +-- default instance, which would be completely wrong. +-- +-- Contrast 'substATBndrs' function with similar substitution functions: +-- +-- * 'substTyVars' does not substitute into the kinds of each type variable, +-- nor does it extend the substitution. 'substTyVars' is meant for occurrences +-- of type variables, whereas 'substATBndr's is meant for binders. +-- +-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution, +-- but it does not apply the substitution to the variables themselves. As +-- such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of +-- 'Type's. +substATBndrs :: Subst -> [TyVar] -> (Subst, [Type]) +substATBndrs = mapAccumL substATBndr where - subst_tv subst tc_tv + substATBndr :: Subst -> TyVar -> (Subst, Type) + substATBndr subst tc_tv + -- Case (1) in the Haddocks | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty) + -- Case (2) in the Haddocks | otherwise - = (extendTvSubst subst tc_tv ty', ty') + = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv') where - ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) + tc_tv' = updateTyVarKind (substTy subst) tc_tv warnMissingAT :: Name -> TcM () warnMissingAT name ===================================== testsuite/tests/deriving/should_compile/T23329.hs ===================================== @@ -0,0 +1,9 @@ +module T23329 where + +import Data.Kind (Type) +import Data.Proxy (Proxy(Proxy)) + +import T23329_M + +foo :: () +foo = myMethod @Type @MyMaybe @() () Proxy Proxy ===================================== testsuite/tests/deriving/should_compile/T23329_M.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module T23329_M where + +import Data.Kind (Type) +import Data.Proxy (Proxy) + +class MyClass (f :: k -> Type) where + type MyTypeFamily f (i :: k) :: Type + myMethod :: MyTypeFamily f i -> Proxy f -> Proxy i -> () + +instance MyClass Maybe where + type MyTypeFamily Maybe i = () + myMethod = undefined + +newtype MyMaybe a = MyMaybe (Maybe a) + deriving MyClass ===================================== testsuite/tests/deriving/should_compile/all.T ===================================== @@ -141,3 +141,4 @@ test('T20994', normal, compile, ['']) test('T22167', normal, compile, ['']) test('T22696a', normal, compile, ['']) test('T22696c', normal, compile, ['']) +test('T23329', normal, multimod_compile, ['T23329', '-v0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78a7d47bd0523483d5008a131e190d92fa8cd4d8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78a7d47bd0523483d5008a131e190d92fa8cd4d8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 08:53:51 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 04:53:51 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Add sized primitive literal syntax Message-ID: <6453729f960a8_e3e063c09fc4805fe@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 070511c8 by Josh Meredith at 2023-05-04T04:53:42-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - b06809ec by Sylvain Henry at 2023-05-04T04:53:42-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - bbe91801 by Andrei Borzenkov at 2023-05-04T04:53:47-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 30 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Lit.hs - docs/users_guide/9.8.1-notes.rst - + docs/users_guide/exts/extended_literals.rst - docs/users_guide/exts/literals.rst - docs/users_guide/exts/primitives.rst - docs/users_guide/exts/stolen_syntax.rst - hadrian/bindist/Makefile - libraries/Cabal - libraries/base/Data/OldList.hs - libraries/base/GHC/Float.hs - libraries/base/GHC/Real.hs - libraries/base/jsbits/base.js - libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f64c919de724052ad7943615e7aeabe9eda3b9f0...bbe918016f9e7bcfd7800affebda90eab8663ee2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f64c919de724052ad7943615e7aeabe9eda3b9f0...bbe918016f9e7bcfd7800affebda90eab8663ee2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 08:55:18 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 04:55:18 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645372f6c4ce3_e3e063a1dbfc809bb@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 654784f7 by Josh Meredith at 2023-05-04T04:54:54-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 6964616e by Sylvain Henry at 2023-05-04T04:54:54-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - c7316c38 by Andrei Borzenkov at 2023-05-04T04:54:58-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbe918016f9e7bcfd7800affebda90eab8663ee2...c7316c38e780c00d7d917018fed9213ec40fda13 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bbe918016f9e7bcfd7800affebda90eab8663ee2...c7316c38e780c00d7d917018fed9213ec40fda13 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 08:56:30 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 04:56:30 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6453733e6cc0c_e3e0651f0481269@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 0bac6520 by Josh Meredith at 2023-05-04T04:56:04-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - d1bbdd92 by Sylvain Henry at 2023-05-04T04:56:04-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 1bbb4cf9 by Andrei Borzenkov at 2023-05-04T04:56:08-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c7316c38e780c00d7d917018fed9213ec40fda13...1bbb4cf9f928c2f6154ae65339ceafe056680ebb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c7316c38e780c00d7d917018fed9213ec40fda13...1bbb4cf9f928c2f6154ae65339ceafe056680ebb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 08:57:41 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 04:57:41 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645373856b587_e3e063c09fc4815c9@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c8a3b1f2 by Josh Meredith at 2023-05-04T04:57:14-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 66c814a2 by Sylvain Henry at 2023-05-04T04:57:14-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - c6cd3ebc by Andrei Borzenkov at 2023-05-04T04:57:18-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1bbb4cf9f928c2f6154ae65339ceafe056680ebb...c6cd3ebc47fca66bc683a4c70388d9a03278b91d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1bbb4cf9f928c2f6154ae65339ceafe056680ebb...c6cd3ebc47fca66bc683a4c70388d9a03278b91d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 08:58:51 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 04:58:51 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645373cb7023b_e3e063a2823c81882@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 6c7dd5e8 by Josh Meredith at 2023-05-04T04:58:25-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 65074e3a by Sylvain Henry at 2023-05-04T04:58:25-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 5f8d4b5b by Andrei Borzenkov at 2023-05-04T04:58:29-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c6cd3ebc47fca66bc683a4c70388d9a03278b91d...5f8d4b5b22488bf51f42c565798b96ece8545228 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c6cd3ebc47fca66bc683a4c70388d9a03278b91d...5f8d4b5b22488bf51f42c565798b96ece8545228 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:00:01 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:00:01 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6453741178017_e3e063a1dbfc8204a@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 9ce33bbd by Josh Meredith at 2023-05-04T04:59:35-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 4f67e726 by Sylvain Henry at 2023-05-04T04:59:35-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 3ed28421 by Andrei Borzenkov at 2023-05-04T04:59:39-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5f8d4b5b22488bf51f42c565798b96ece8545228...3ed28421430bd467e738cf318cf0b7ef6fded596 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5f8d4b5b22488bf51f42c565798b96ece8545228...3ed28421430bd467e738cf318cf0b7ef6fded596 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:01:10 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:01:10 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <64537456b721d_e3e063c09fc4824cf@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 6d682513 by Josh Meredith at 2023-05-04T05:00:44-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - ed247deb by Sylvain Henry at 2023-05-04T05:00:44-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 32c6fc28 by Andrei Borzenkov at 2023-05-04T05:00:49-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ed28421430bd467e738cf318cf0b7ef6fded596...32c6fc28a16b940e096b7aeffd1c762972dde0c0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ed28421430bd467e738cf318cf0b7ef6fded596...32c6fc28a16b940e096b7aeffd1c762972dde0c0 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:02:21 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:02:21 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6453749d215c2_e3e063a2823c8292b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c2afea6c by Josh Meredith at 2023-05-04T05:01:55-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - ac07053a by Sylvain Henry at 2023-05-04T05:01:55-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - c24238eb by Andrei Borzenkov at 2023-05-04T05:01:59-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32c6fc28a16b940e096b7aeffd1c762972dde0c0...c24238eb417e0e87a3bd002b17e15cc34b401168 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32c6fc28a16b940e096b7aeffd1c762972dde0c0...c24238eb417e0e87a3bd002b17e15cc34b401168 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:03:28 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:03:28 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645374e0d841_e3e063c09fc48325f@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e1994f28 by Josh Meredith at 2023-05-04T05:03:04-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - fb2a6831 by Sylvain Henry at 2023-05-04T05:03:04-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 8761b422 by Andrei Borzenkov at 2023-05-04T05:03:08-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c24238eb417e0e87a3bd002b17e15cc34b401168...8761b4226023be9cc4e0dfde16ac91c0bdaf440f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c24238eb417e0e87a3bd002b17e15cc34b401168...8761b4226023be9cc4e0dfde16ac91c0bdaf440f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:04:38 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:04:38 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <64537526cf7b5_e3e06383121c83593@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4bb05258 by Josh Meredith at 2023-05-04T05:04:14-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 7d76694a by Sylvain Henry at 2023-05-04T05:04:14-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 2ec5fd54 by Andrei Borzenkov at 2023-05-04T05:04:18-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8761b4226023be9cc4e0dfde16ac91c0bdaf440f...2ec5fd54e5028e7e495278982a81ddd7b91f1af8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8761b4226023be9cc4e0dfde16ac91c0bdaf440f...2ec5fd54e5028e7e495278982a81ddd7b91f1af8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:05:51 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:05:51 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6453756faee19_e3e06361b16c838d1@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 970e41ff by Josh Meredith at 2023-05-04T05:05:23-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - ee0466ad by Sylvain Henry at 2023-05-04T05:05:23-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - a19d1f5c by Andrei Borzenkov at 2023-05-04T05:05:27-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ec5fd54e5028e7e495278982a81ddd7b91f1af8...a19d1f5ca4702ef4db4000042016fe7910690469 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ec5fd54e5028e7e495278982a81ddd7b91f1af8...a19d1f5ca4702ef4db4000042016fe7910690469 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:07:00 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:07:00 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645375b4a5ccb_e3e063c08c8c841bd@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 88ee44ca by Josh Meredith at 2023-05-04T05:06:34-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 341a41a2 by Sylvain Henry at 2023-05-04T05:06:34-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 5422999b by Andrei Borzenkov at 2023-05-04T05:06:37-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a19d1f5ca4702ef4db4000042016fe7910690469...5422999b3f4d1d9e9f490e7fcf3b820903dbe134 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a19d1f5ca4702ef4db4000042016fe7910690469...5422999b3f4d1d9e9f490e7fcf3b820903dbe134 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:08:08 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:08:08 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645375f8b9648_e3e063a1dbfc844e4@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 29d9b75b by Josh Meredith at 2023-05-04T05:07:43-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 6761f73e by Sylvain Henry at 2023-05-04T05:07:43-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 26c496cb by Andrei Borzenkov at 2023-05-04T05:07:47-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5422999b3f4d1d9e9f490e7fcf3b820903dbe134...26c496cb43c62387319beba2417eaa03c8660f11 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5422999b3f4d1d9e9f490e7fcf3b820903dbe134...26c496cb43c62387319beba2417eaa03c8660f11 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:09:19 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:09:19 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6453763fc0f13_e3e0651f048471b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b6346908 by Josh Meredith at 2023-05-04T05:08:52-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 9883fec2 by Sylvain Henry at 2023-05-04T05:08:53-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - a9672780 by Andrei Borzenkov at 2023-05-04T05:08:56-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/26c496cb43c62387319beba2417eaa03c8660f11...a9672780fb3885ba8f28de9900488267d3c8ec36 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/26c496cb43c62387319beba2417eaa03c8660f11...a9672780fb3885ba8f28de9900488267d3c8ec36 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:10:28 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:10:28 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6453768459c5e_e3e06383121c850f7@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 1d408f8c by Josh Meredith at 2023-05-04T05:10:02-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 40e6046f by Sylvain Henry at 2023-05-04T05:10:02-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - f37cac5c by Andrei Borzenkov at 2023-05-04T05:10:06-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9672780fb3885ba8f28de9900488267d3c8ec36...f37cac5c6abde992dd12c7a97a4f7d51f2d83ae3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9672780fb3885ba8f28de9900488267d3c8ec36...f37cac5c6abde992dd12c7a97a4f7d51f2d83ae3 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:11:34 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:11:34 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645376c68b76d_e3e0651f04871df@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 2ff40ce5 by Josh Meredith at 2023-05-04T05:11:11-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2b28cfb2 by Sylvain Henry at 2023-05-04T05:11:11-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 8d07eef3 by Andrei Borzenkov at 2023-05-04T05:11:15-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f37cac5c6abde992dd12c7a97a4f7d51f2d83ae3...8d07eef39011ce52755e1016be34c354735a465b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f37cac5c6abde992dd12c7a97a4f7d51f2d83ae3...8d07eef39011ce52755e1016be34c354735a465b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:12:46 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:12:46 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6453770eaeaeb_e3e0651f04874ba@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 0cbe43e5 by Josh Meredith at 2023-05-04T05:12:20-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 4e3e477a by Sylvain Henry at 2023-05-04T05:12:20-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 26b436cd by Andrei Borzenkov at 2023-05-04T05:12:24-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d07eef39011ce52755e1016be34c354735a465b...26b436cdab3e2ce703f21939599cfd8f2a6d9613 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d07eef39011ce52755e1016be34c354735a465b...26b436cdab3e2ce703f21939599cfd8f2a6d9613 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:13:56 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:13:56 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645377541a2dd_e3e06383121c8772f@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4a352531 by Josh Meredith at 2023-05-04T05:13:30-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - ad51977f by Sylvain Henry at 2023-05-04T05:13:30-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 38dfd648 by Andrei Borzenkov at 2023-05-04T05:13:34-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/26b436cdab3e2ce703f21939599cfd8f2a6d9613...38dfd648564b8a9595a4fa4d67bf5d2c44913d76 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/26b436cdab3e2ce703f21939599cfd8f2a6d9613...38dfd648564b8a9595a4fa4d67bf5d2c44913d76 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:15:07 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:15:07 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6453779b3b7b_e3e063a20fc8880eb@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4a8e1b07 by Josh Meredith at 2023-05-04T05:14:40-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - d07e99c2 by Sylvain Henry at 2023-05-04T05:14:40-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 46fdfafa by Andrei Borzenkov at 2023-05-04T05:14:44-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/38dfd648564b8a9595a4fa4d67bf5d2c44913d76...46fdfafad9e5094119d7083fe2688e9bc58a04f0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/38dfd648564b8a9595a4fa4d67bf5d2c44913d76...46fdfafad9e5094119d7083fe2688e9bc58a04f0 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:16:15 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:16:15 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: JS: fix bounds checking (Issue 23123) Message-ID: <645377df68046_e3e0631e7280900e9@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 0178ca2c by Josh Meredith at 2023-05-04T05:15:50-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - ea1474f3 by Sylvain Henry at 2023-05-04T05:15:50-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - b02133a8 by Andrei Borzenkov at 2023-05-04T05:15:54-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 11 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/Data/OldList.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46fdfafad9e5094119d7083fe2688e9bc58a04f0...b02133a8ea0d3d5e01be6e29b9ffae072e72614d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46fdfafad9e5094119d7083fe2688e9bc58a04f0...b02133a8ea0d3d5e01be6e29b9ffae072e72614d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:18:14 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:18:14 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <64537856ee30b_e3e0631e72809021b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: cf9590fa by Matthew Pickering at 2023-05-04T05:18:06-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 33d145e0 by romes at 2023-05-04T05:18:06-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6de327f3 by romes at 2023-05-04T05:18:06-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - fd1a5cfa by romes at 2023-05-04T05:18:06-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 82e674c9 by Matthew Pickering at 2023-05-04T05:18:06-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 55f44f23 by Josh Meredith at 2023-05-04T05:18:07-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 1272cd33 by Sylvain Henry at 2023-05-04T05:18:07-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - acd07157 by Andrei Borzenkov at 2023-05-04T05:18:10-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 12 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b02133a8ea0d3d5e01be6e29b9ffae072e72614d...acd0715737fa2f560dc1eaabc2846615b4a05278 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b02133a8ea0d3d5e01be6e29b9ffae072e72614d...acd0715737fa2f560dc1eaabc2846615b4a05278 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:19:26 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:19:26 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453789e1cc1f_e3e0651f04907a6@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d043fb12 by Matthew Pickering at 2023-05-04T05:19:17-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 6fac596b by romes at 2023-05-04T05:19:17-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 019aa396 by romes at 2023-05-04T05:19:17-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 59f97041 by romes at 2023-05-04T05:19:17-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 0cab5919 by Matthew Pickering at 2023-05-04T05:19:17-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 5a593437 by Josh Meredith at 2023-05-04T05:19:18-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 224eb59e by Sylvain Henry at 2023-05-04T05:19:18-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 31df68ab by Andrei Borzenkov at 2023-05-04T05:19:22-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 12 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/acd0715737fa2f560dc1eaabc2846615b4a05278...31df68abf6cb2279c5c4abbf9ab1c29bc121c9c1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/acd0715737fa2f560dc1eaabc2846615b4a05278...31df68abf6cb2279c5c4abbf9ab1c29bc121c9c1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:20:36 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:20:36 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645378e4357a7_e3e06383121c91092@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 574e94ab by Matthew Pickering at 2023-05-04T05:20:28-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 4aa95141 by romes at 2023-05-04T05:20:28-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - b37ca66c by romes at 2023-05-04T05:20:28-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 36c802ce by romes at 2023-05-04T05:20:28-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 7df750da by Matthew Pickering at 2023-05-04T05:20:28-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - dbe897a7 by Josh Meredith at 2023-05-04T05:20:29-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 197ee1c2 by Sylvain Henry at 2023-05-04T05:20:29-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - c2824dc0 by Andrei Borzenkov at 2023-05-04T05:20:33-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 12 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31df68abf6cb2279c5c4abbf9ab1c29bc121c9c1...c2824dc019039df474cb9e6100bfc6dbf307f345 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31df68abf6cb2279c5c4abbf9ab1c29bc121c9c1...c2824dc019039df474cb9e6100bfc6dbf307f345 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:21:47 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:21:47 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453792b180f_e3e06383121c913fb@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 99d0701d by Matthew Pickering at 2023-05-04T05:21:39-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 4e4abbb4 by romes at 2023-05-04T05:21:39-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 30e6137d by romes at 2023-05-04T05:21:39-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - df979ad6 by romes at 2023-05-04T05:21:39-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 7ceb02ab by Matthew Pickering at 2023-05-04T05:21:39-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 76dd5c8f by Josh Meredith at 2023-05-04T05:21:39-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 74ce12c0 by Sylvain Henry at 2023-05-04T05:21:39-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - b7737568 by Andrei Borzenkov at 2023-05-04T05:21:43-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 12 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2824dc019039df474cb9e6100bfc6dbf307f345...b7737568bf522461cc04e423825203b5ced1f6db -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c2824dc019039df474cb9e6100bfc6dbf307f345...b7737568bf522461cc04e423825203b5ced1f6db You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:22:59 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:22:59 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <64537973ed09_e3e06383121c954d@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 482ecb30 by Matthew Pickering at 2023-05-04T05:22:50-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - eab6eafb by romes at 2023-05-04T05:22:50-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 4ca65c75 by romes at 2023-05-04T05:22:50-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - b8356f39 by romes at 2023-05-04T05:22:50-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 5a242e6c by Matthew Pickering at 2023-05-04T05:22:51-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - dd168099 by Andrei Borzenkov at 2023-05-04T05:22:54-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 12 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json - hadrian/bootstrap/plan-9_2_2.json - hadrian/bootstrap/plan-9_2_3.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7737568bf522461cc04e423825203b5ced1f6db...dd168099cbd34777194259fb2e27eed58e85a37d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7737568bf522461cc04e423825203b5ced1f6db...dd168099cbd34777194259fb2e27eed58e85a37d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:24:07 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:24:07 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645379b7dc2e6_e3e063a1dbfc9574f@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 7ded58c6 by Matthew Pickering at 2023-05-04T05:24:00-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - c18005f0 by romes at 2023-05-04T05:24:00-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 162ada61 by romes at 2023-05-04T05:24:00-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 38a4470d by romes at 2023-05-04T05:24:00-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 1af7b6a8 by Matthew Pickering at 2023-05-04T05:24:01-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 3f232f3b by Andrei Borzenkov at 2023-05-04T05:24:04-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 12 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json - hadrian/bootstrap/plan-9_2_2.json - hadrian/bootstrap/plan-9_2_3.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd168099cbd34777194259fb2e27eed58e85a37d...3f232f3b04546a5040089c97fcebe0fae8326ca6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd168099cbd34777194259fb2e27eed58e85a37d...3f232f3b04546a5040089c97fcebe0fae8326ca6 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:25:19 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:25:19 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645379ff1fea3_e3e063c09fc498051@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f7658931 by Matthew Pickering at 2023-05-04T05:25:12-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 8fcc15dc by romes at 2023-05-04T05:25:12-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - aa8375b6 by romes at 2023-05-04T05:25:12-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - a2ace6b4 by romes at 2023-05-04T05:25:12-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 8f95a2bf by Matthew Pickering at 2023-05-04T05:25:12-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 9c50a78a by Andrei Borzenkov at 2023-05-04T05:25:16-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 12 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json - hadrian/bootstrap/plan-9_2_2.json - hadrian/bootstrap/plan-9_2_3.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3f232f3b04546a5040089c97fcebe0fae8326ca6...9c50a78abe150c530196d4199c00ac934893f506 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3f232f3b04546a5040089c97fcebe0fae8326ca6...9c50a78abe150c530196d4199c00ac934893f506 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:56:39 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:56:39 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <64538157d3d9c_e3e0651f0410879@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d198dade by Matthew Pickering at 2023-05-04T05:56:35-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - c897646f by romes at 2023-05-04T05:56:35-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - e38f16e6 by romes at 2023-05-04T05:56:35-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 1b372a17 by romes at 2023-05-04T05:56:35-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - ad1036cf by Matthew Pickering at 2023-05-04T05:56:35-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 9d64c261 by Josh Meredith at 2023-05-04T05:56:36-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 0756fbff by Sylvain Henry at 2023-05-04T05:56:36-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 094c04d9 by Krzysztof Gogolewski at 2023-05-04T05:56:36-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9c50a78abe150c530196d4199c00ac934893f506...094c04d91ca67f05ce4357bc95a8cf0bcb4ea588 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9c50a78abe150c530196d4199c00ac934893f506...094c04d91ca67f05ce4357bc95a8cf0bcb4ea588 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:57:50 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:57:50 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453819ed23fd_e3e063c09fd8109071@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4c37a04a by Matthew Pickering at 2023-05-04T05:57:43-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 69527c0f by romes at 2023-05-04T05:57:43-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - c622035f by romes at 2023-05-04T05:57:43-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 3683bb11 by romes at 2023-05-04T05:57:43-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 0861cbff by Matthew Pickering at 2023-05-04T05:57:43-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 2ee60455 by Josh Meredith at 2023-05-04T05:57:44-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - d928e35b by Sylvain Henry at 2023-05-04T05:57:44-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - a03a6ced by Krzysztof Gogolewski at 2023-05-04T05:57:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/094c04d91ca67f05ce4357bc95a8cf0bcb4ea588...a03a6cedb67f9ed3a0a92178d44028d521069dff -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/094c04d91ca67f05ce4357bc95a8cf0bcb4ea588...a03a6cedb67f9ed3a0a92178d44028d521069dff You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 09:58:55 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 05:58:55 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645381dfb6909_e3e06361b16c109399@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: ed733f44 by Matthew Pickering at 2023-05-04T05:58:51-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 7990027d by romes at 2023-05-04T05:58:51-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - ea88b382 by romes at 2023-05-04T05:58:51-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 2239f15c by romes at 2023-05-04T05:58:51-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 9b2d4e8b by Matthew Pickering at 2023-05-04T05:58:51-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - b2dc0d7f by Josh Meredith at 2023-05-04T05:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 0babe1c5 by Sylvain Henry at 2023-05-04T05:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 7c8c29df by Krzysztof Gogolewski at 2023-05-04T05:58:52-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a03a6cedb67f9ed3a0a92178d44028d521069dff...7c8c29dfd40f6409d0999701abb19ffa79d5118d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a03a6cedb67f9ed3a0a92178d44028d521069dff...7c8c29dfd40f6409d0999701abb19ffa79d5118d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:00:06 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:00:06 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453822664412_e3e0651f04109642@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 9857f42b by Matthew Pickering at 2023-05-04T06:00:00-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 7289a040 by romes at 2023-05-04T06:00:00-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 5acecb1f by romes at 2023-05-04T06:00:00-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 21334759 by romes at 2023-05-04T06:00:00-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 969cc154 by Matthew Pickering at 2023-05-04T06:00:00-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 60745b80 by Josh Meredith at 2023-05-04T06:00:01-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - a42dd08e by Sylvain Henry at 2023-05-04T06:00:01-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - e275eb45 by Krzysztof Gogolewski at 2023-05-04T06:00:01-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7c8c29dfd40f6409d0999701abb19ffa79d5118d...e275eb4504595d711df25b829061a6b020dd83d3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7c8c29dfd40f6409d0999701abb19ffa79d5118d...e275eb4504595d711df25b829061a6b020dd83d3 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:01:14 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:01:14 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453826a318dc_e3e063a2823c109956@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: fa76c2f9 by Matthew Pickering at 2023-05-04T06:01:09-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - f8f21d40 by romes at 2023-05-04T06:01:09-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 7b7630b1 by romes at 2023-05-04T06:01:09-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 456eda04 by romes at 2023-05-04T06:01:09-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - d145b224 by Matthew Pickering at 2023-05-04T06:01:10-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - b51670e0 by Josh Meredith at 2023-05-04T06:01:10-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - fd80edde by Sylvain Henry at 2023-05-04T06:01:10-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 1b202651 by Krzysztof Gogolewski at 2023-05-04T06:01:11-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e275eb4504595d711df25b829061a6b020dd83d3...1b202651bcddade2c29ae9c5cb4a9d488c1f2ba1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e275eb4504595d711df25b829061a6b020dd83d3...1b202651bcddade2c29ae9c5cb4a9d488c1f2ba1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:02:28 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:02:28 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645382b4996de_e3e06361b16c110266@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a781fb3f by Matthew Pickering at 2023-05-04T06:02:24-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 6d78d7c9 by romes at 2023-05-04T06:02:24-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 923aeb47 by romes at 2023-05-04T06:02:24-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 2b48c5dc by romes at 2023-05-04T06:02:24-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - f39c613c by Matthew Pickering at 2023-05-04T06:02:24-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 561f98a3 by Josh Meredith at 2023-05-04T06:02:24-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 5e19367e by Sylvain Henry at 2023-05-04T06:02:24-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - e94f1928 by Krzysztof Gogolewski at 2023-05-04T06:02:25-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1b202651bcddade2c29ae9c5cb4a9d488c1f2ba1...e94f1928921c8b665e9286f099bbd32094aa1274 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1b202651bcddade2c29ae9c5cb4a9d488c1f2ba1...e94f1928921c8b665e9286f099bbd32094aa1274 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:03:37 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:03:37 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645382f9f034d_e3e0651f0411057e@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: bdacd1d5 by Matthew Pickering at 2023-05-04T06:03:32-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - c741da5e by romes at 2023-05-04T06:03:32-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 5d5e8e12 by romes at 2023-05-04T06:03:32-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - c6180d01 by romes at 2023-05-04T06:03:32-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - c96953da by Matthew Pickering at 2023-05-04T06:03:32-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 5f08da8f by Josh Meredith at 2023-05-04T06:03:33-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - a73fce37 by Sylvain Henry at 2023-05-04T06:03:33-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - deec3395 by Krzysztof Gogolewski at 2023-05-04T06:03:33-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e94f1928921c8b665e9286f099bbd32094aa1274...deec3395ee28c7e69b4599bc0b97b184785bdb31 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e94f1928921c8b665e9286f099bbd32094aa1274...deec3395ee28c7e69b4599bc0b97b184785bdb31 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:04:50 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:04:50 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645383428a656_e3e063a2823c1108d1@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8f127211 by Matthew Pickering at 2023-05-04T06:04:41-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 445c1055 by romes at 2023-05-04T06:04:41-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 1155138c by romes at 2023-05-04T06:04:41-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 29a76b57 by romes at 2023-05-04T06:04:41-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 141fa361 by Matthew Pickering at 2023-05-04T06:04:41-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 861c541d by Josh Meredith at 2023-05-04T06:04:41-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 345bace5 by Sylvain Henry at 2023-05-04T06:04:41-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - cf655847 by Krzysztof Gogolewski at 2023-05-04T06:04:42-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/deec3395ee28c7e69b4599bc0b97b184785bdb31...cf655847427461d2d2c022621fbd29b9eee3916b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/deec3395ee28c7e69b4599bc0b97b184785bdb31...cf655847427461d2d2c022621fbd29b9eee3916b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:05:55 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:05:55 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453838378f76_e3e063c09fd8111142@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a60d134e by Matthew Pickering at 2023-05-04T06:05:50-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 86476dd6 by romes at 2023-05-04T06:05:50-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - e0dc2029 by romes at 2023-05-04T06:05:50-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - a00596bf by romes at 2023-05-04T06:05:50-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 75548201 by Matthew Pickering at 2023-05-04T06:05:50-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 21c0df9f by Josh Meredith at 2023-05-04T06:05:50-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 6dda3932 by Sylvain Henry at 2023-05-04T06:05:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - d94d4f80 by Krzysztof Gogolewski at 2023-05-04T06:05:51-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf655847427461d2d2c022621fbd29b9eee3916b...d94d4f8005713f2932ff3e6d27b66e1502b9c8a2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf655847427461d2d2c022621fbd29b9eee3916b...d94d4f8005713f2932ff3e6d27b66e1502b9c8a2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:07:04 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:07:04 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645383c85b765_e3e06361b16c11142c@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8746a100 by Matthew Pickering at 2023-05-04T06:06:59-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - b47c891c by romes at 2023-05-04T06:06:59-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 49e982f2 by romes at 2023-05-04T06:06:59-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 0e4fe4e2 by romes at 2023-05-04T06:06:59-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 94fddee5 by Matthew Pickering at 2023-05-04T06:06:59-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 528172d7 by Josh Meredith at 2023-05-04T06:06:59-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 8f49cc65 by Sylvain Henry at 2023-05-04T06:06:59-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 8d01b082 by Krzysztof Gogolewski at 2023-05-04T06:07:00-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d94d4f8005713f2932ff3e6d27b66e1502b9c8a2...8d01b082ff59cf14ff6e9228368b8906c53004b8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d94d4f8005713f2932ff3e6d27b66e1502b9c8a2...8d01b082ff59cf14ff6e9228368b8906c53004b8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:08:12 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:08:12 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453840c1b9ad_e3e06383121c111773@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b5240ed2 by Matthew Pickering at 2023-05-04T06:08:06-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - de9a03bf by romes at 2023-05-04T06:08:06-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 8b33f1a2 by romes at 2023-05-04T06:08:06-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 368cde61 by romes at 2023-05-04T06:08:06-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - a4ffee60 by Matthew Pickering at 2023-05-04T06:08:06-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 5f45e27e by Josh Meredith at 2023-05-04T06:08:06-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - db3bcc95 by Sylvain Henry at 2023-05-04T06:08:06-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - af7eddf8 by Krzysztof Gogolewski at 2023-05-04T06:08:07-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d01b082ff59cf14ff6e9228368b8906c53004b8...af7eddf80d0407f5683b617a0c26c9c036bafe12 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d01b082ff59cf14ff6e9228368b8906c53004b8...af7eddf80d0407f5683b617a0c26c9c036bafe12 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:09:18 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:09:18 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453844e93072_e3e06383121c11206f@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 9368fc23 by Matthew Pickering at 2023-05-04T06:09:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 30bd68c2 by romes at 2023-05-04T06:09:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 2b3ac9cc by romes at 2023-05-04T06:09:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 90b2e208 by romes at 2023-05-04T06:09:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 29621f9d by Matthew Pickering at 2023-05-04T06:09:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - f28366cd by Josh Meredith at 2023-05-04T06:09:14-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 28a54f74 by Sylvain Henry at 2023-05-04T06:09:14-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 728ed886 by Krzysztof Gogolewski at 2023-05-04T06:09:15-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/af7eddf80d0407f5683b617a0c26c9c036bafe12...728ed886d0ed0d9941cec52e117a7071df698068 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/af7eddf80d0407f5683b617a0c26c9c036bafe12...728ed886d0ed0d9941cec52e117a7071df698068 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:10:27 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:10:27 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645384932eaec_e3e0651f0411238f@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c66f1d5d by Matthew Pickering at 2023-05-04T06:10:22-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 9366cbc4 by romes at 2023-05-04T06:10:22-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - cabdd121 by romes at 2023-05-04T06:10:22-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - ca89d786 by romes at 2023-05-04T06:10:22-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 6956468c by Matthew Pickering at 2023-05-04T06:10:22-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 8b06eac9 by Josh Meredith at 2023-05-04T06:10:23-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - d5de2dca by Sylvain Henry at 2023-05-04T06:10:23-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - f7ee38ff by Krzysztof Gogolewski at 2023-05-04T06:10:24-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/728ed886d0ed0d9941cec52e117a7071df698068...f7ee38ffa49e9fcfbe6a4ab23d509ca21f14ffb9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/728ed886d0ed0d9941cec52e117a7071df698068...f7ee38ffa49e9fcfbe6a4ab23d509ca21f14ffb9 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:11:37 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:11:37 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645384d9d8e43_e3e06361b16c1126ee@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 776e592a by Matthew Pickering at 2023-05-04T06:11:33-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - ad0c9835 by romes at 2023-05-04T06:11:33-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 03e642d3 by romes at 2023-05-04T06:11:33-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - e95bba83 by romes at 2023-05-04T06:11:33-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 2b1d1a1c by Matthew Pickering at 2023-05-04T06:11:33-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 3e6938b3 by Josh Meredith at 2023-05-04T06:11:33-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - bb786b40 by Sylvain Henry at 2023-05-04T06:11:33-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 353c1916 by Krzysztof Gogolewski at 2023-05-04T06:11:34-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7ee38ffa49e9fcfbe6a4ab23d509ca21f14ffb9...353c19161e64d6b226722abe9bdb2c9aa1bd213f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7ee38ffa49e9fcfbe6a4ab23d509ca21f14ffb9...353c19161e64d6b226722abe9bdb2c9aa1bd213f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:12:47 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:12:47 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453851fe5e10_e3e06361b16c11441f@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a7d0f40c by Matthew Pickering at 2023-05-04T06:12:43-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - da17e884 by romes at 2023-05-04T06:12:43-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 3f864366 by romes at 2023-05-04T06:12:43-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 24eedd8f by romes at 2023-05-04T06:12:43-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - b965e39d by Matthew Pickering at 2023-05-04T06:12:43-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - f51ea65d by Josh Meredith at 2023-05-04T06:12:43-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - ddd19052 by Sylvain Henry at 2023-05-04T06:12:43-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - e722df37 by Krzysztof Gogolewski at 2023-05-04T06:12:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/353c19161e64d6b226722abe9bdb2c9aa1bd213f...e722df375b3a78924726cce152a3c06dd9760a4e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/353c19161e64d6b226722abe9bdb2c9aa1bd213f...e722df375b3a78924726cce152a3c06dd9760a4e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:13:56 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:13:56 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <64538564a5458_e3e063a20fc81147aa@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 441836fa by Matthew Pickering at 2023-05-04T06:13:52-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - cb7f2b8e by romes at 2023-05-04T06:13:52-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 8f7b81ac by romes at 2023-05-04T06:13:52-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 8c7451c4 by romes at 2023-05-04T06:13:52-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 5f7d91cc by Matthew Pickering at 2023-05-04T06:13:52-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 639b2677 by Josh Meredith at 2023-05-04T06:13:52-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 5666c6e5 by Sylvain Henry at 2023-05-04T06:13:52-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 7f30a8c0 by Krzysztof Gogolewski at 2023-05-04T06:13:53-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e722df375b3a78924726cce152a3c06dd9760a4e...7f30a8c00fce98e531e73425e4aee03235555506 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e722df375b3a78924726cce152a3c06dd9760a4e...7f30a8c00fce98e531e73425e4aee03235555506 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:15:07 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:15:07 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645385ab3516a_e3e0631e72801166a3@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 19f00225 by Matthew Pickering at 2023-05-04T06:15:01-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - b6f0accc by romes at 2023-05-04T06:15:01-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 3f3c18e7 by romes at 2023-05-04T06:15:01-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - b5751a3e by romes at 2023-05-04T06:15:01-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 924392cc by Matthew Pickering at 2023-05-04T06:15:01-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 2e523be5 by Josh Meredith at 2023-05-04T06:15:01-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 03914522 by Sylvain Henry at 2023-05-04T06:15:01-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - e40012ef by Krzysztof Gogolewski at 2023-05-04T06:15:02-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7f30a8c00fce98e531e73425e4aee03235555506...e40012ef77e930ce16c8be8e12f71e9b93e24889 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7f30a8c00fce98e531e73425e4aee03235555506...e40012ef77e930ce16c8be8e12f71e9b93e24889 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:16:14 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:16:14 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645385ee26115_e3e063c08c8c11697b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e56b4947 by Matthew Pickering at 2023-05-04T06:16:09-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - b6b6025b by romes at 2023-05-04T06:16:09-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - b443b01f by romes at 2023-05-04T06:16:09-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 70aa4125 by romes at 2023-05-04T06:16:09-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 6949b37e by Matthew Pickering at 2023-05-04T06:16:09-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - e41038e5 by Josh Meredith at 2023-05-04T06:16:10-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 83107976 by Sylvain Henry at 2023-05-04T06:16:10-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - ff947102 by Krzysztof Gogolewski at 2023-05-04T06:16:10-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e40012ef77e930ce16c8be8e12f71e9b93e24889...ff9471023d38e25369b3baf7308e37ee3ac5e035 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e40012ef77e930ce16c8be8e12f71e9b93e24889...ff9471023d38e25369b3baf7308e37ee3ac5e035 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:17:25 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:17:25 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645386351b318_e3e063c08c8c1172a@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 0cf522bf by Matthew Pickering at 2023-05-04T06:17:18-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - cf594e09 by romes at 2023-05-04T06:17:18-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 961ec085 by romes at 2023-05-04T06:17:18-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - e49c829e by romes at 2023-05-04T06:17:18-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - e7a06d89 by Matthew Pickering at 2023-05-04T06:17:18-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - d6fc2ee0 by Josh Meredith at 2023-05-04T06:17:19-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 848b8548 by Sylvain Henry at 2023-05-04T06:17:19-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 0be41615 by Krzysztof Gogolewski at 2023-05-04T06:17:19-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff9471023d38e25369b3baf7308e37ee3ac5e035...0be416153202a62cd9d4617165510f62ac9a18fc -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff9471023d38e25369b3baf7308e37ee3ac5e035...0be416153202a62cd9d4617165510f62ac9a18fc You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:23:37 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:23:37 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <645387a9bc283_e3e0631e7280119481@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8add60e2 by Matthew Pickering at 2023-05-04T06:23:33-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 9b06ec8e by romes at 2023-05-04T06:23:33-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6b3ff4e7 by romes at 2023-05-04T06:23:33-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - 7ef8e0f3 by romes at 2023-05-04T06:23:33-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - b711c527 by Matthew Pickering at 2023-05-04T06:23:33-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 8e9d555b by Josh Meredith at 2023-05-04T06:23:34-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 3b632fd9 by Sylvain Henry at 2023-05-04T06:23:34-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - cb372361 by Krzysztof Gogolewski at 2023-05-04T06:23:34-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 15 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0be416153202a62cd9d4617165510f62ac9a18fc...cb3723616650328f7d2cf405995b586fa12707d1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0be416153202a62cd9d4617165510f62ac9a18fc...cb3723616650328f7d2cf405995b586fa12707d1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:25:49 2023 From: gitlab at gitlab.haskell.org (Bryan R (@chreekat)) Date: Thu, 04 May 2023 06:25:49 -0400 Subject: [Git][ghc/ghc] Deleted branch wip/marge_bot_batch_merge_job Message-ID: <6453882d3488f_e3e0631e728012306@gitlab.mail> Bryan R deleted branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:27:11 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 06:27:11 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/marge_bot_batch_merge_job Message-ID: <6453887f2b3f2_e3e063a2823c123224@gitlab.mail> Marge Bot pushed new branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/marge_bot_batch_merge_job You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:33:09 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Thu, 04 May 2023 06:33:09 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <645389e56f314_e3e063a20fc81321c8@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 092d2d82 by Josh Meredith at 2023-05-04T10:32:57+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 9 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/CoreUtils.hs - compiler/GHC/StgToJS/DataCon.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -6,13 +6,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform ( identsS , identsV , identsE -- * Saturation - , jsSaturate + , satJStat + , satJExpr -- * Generic traversal (via compos) , JMacro(..) , JMGadt(..) @@ -21,8 +23,6 @@ module GHC.JS.Transform , composOpM , composOpM_ , composOpFold - , satJExpr - , satJStat ) where @@ -33,11 +33,12 @@ import GHC.JS.Unsat.Syntax import Data.Functor.Identity import Control.Monad -import Control.Arrow ((***)) +import Data.List (sortBy) import GHC.Data.FastString import GHC.Utils.Monad.State.Strict import GHC.Types.Unique.Map +import GHC.Types.Unique.FM {-# INLINE identsS #-} @@ -200,66 +201,56 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v - - --------------------------------------------------------------------------------- --- Translation --- --- This will be moved after GHC.JS.Syntax is removed --------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing - - -- This is an Applicative but we can't use it because no type variables :( - witness :: JStat -> Sat.JStat - witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) - witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) - witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) - witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) - witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i - (satJExpr iter) - (witness body) - witness (SwitchStat struct ps def) = Sat.SwitchStat - (satJExpr struct) - (map (satJExpr *** witness) ps) - (witness def) - witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) - witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs - witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) - witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) - witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) - witness (BreakStat Nothing) = Sat.BreakStat Nothing - witness (BreakStat (Just l)) = Sat.BreakStat $! Just l - witness (ContinueStat Nothing) = Sat.ContinueStat Nothing - witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l - witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" - - -satJExpr :: JExpr -> Sat.JExpr -satJExpr = go - where - go (ValExpr v) = Sat.ValExpr (satJVal v) - go (SelExpr obj i) = Sat.SelExpr (satJExpr obj) i - go (IdxExpr o i) = Sat.IdxExpr (satJExpr o) (satJExpr i) - go (InfixExpr op l r) = Sat.InfixExpr (satJOp op) (satJExpr l) (satJExpr r) - go (UOpExpr op r) = Sat.UOpExpr (satJUOp op) (satJExpr r) - go (IfExpr c t e) = Sat.IfExpr (satJExpr c) (satJExpr t) (satJExpr e) - go (ApplExpr rator rands) = Sat.ApplExpr (satJExpr rator) (satJExpr <$> rands) - go UnsatExpr{} = error "satJExpr: discovered an Unsat...impossibly" +satJStat :: Maybe FastString -> JStat -> Sat.JStat +satJStat str x = evalState (jsSaturateS x) (newIdentSupply str) + +satJExpr :: Maybe FastString -> JExpr -> Sat.JExpr +satJExpr str x = evalState (jsSaturateE x) (newIdentSupply str) + +jsSaturateS :: JStat -> State [Ident] Sat.JStat +jsSaturateS = \case + DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs + ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e + IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e + WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e + ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body + SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct + <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps + <*> jsSaturateS def + TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f + BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs + ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand + UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand + AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> jsSaturateE rhs + LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt + BreakStat m_l -> return $ Sat.BreakStat $! m_l + ContinueStat m_l -> return $ Sat.ContinueStat $! m_l + UnsatBlock us -> jsSaturateS =<< runIdentSupply us + +jsSaturateE :: JExpr -> State [Ident] Sat.JExpr +jsSaturateE = \case + ValExpr v -> Sat.ValExpr <$> jsSaturateV v + SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i + IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i + InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r + UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r + IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e + ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands + UnsatExpr us -> jsSaturateE =<< runIdentSupply us + +jsSaturateV :: JVal -> State [Ident] Sat.JVal +jsSaturateV = \case + JVar i -> return $ Sat.JVar i + JList xs -> Sat.JList <$> mapM jsSaturateE xs + JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) + JInt i -> return $ Sat.JInt i + JStr s -> return $ Sat.JStr s + JRegEx f -> return $ Sat.JRegEx f + JHash (UniqMap m) -> Sat.JHash . UniqMap . listToUFM + <$> ( mapM (\(f, x) -> jsSaturateE x >>= \x' -> return (f, (f, x')) ) + . sortBy (\x y -> fst x `lexicalCompareFS` fst y) $ nonDetEltsUFM m ) + JFunc args body -> Sat.JFunc args <$> jsSaturateS body + UnsatVal us -> jsSaturateV =<< runIdentSupply us satJOp :: JOp -> Sat.Op satJOp = go @@ -305,15 +296,3 @@ satJUOp = go go PreDecOp = Sat.PreDecOp go PostDecOp = Sat.PostDecOp -satJVal :: JVal -> Sat.JVal -satJVal = go - where - go (JVar i) = Sat.JVar i - go (JList xs) = Sat.JList (satJExpr <$> xs) - go (JDouble d) = Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) - go (JInt i) = Sat.JInt i - go (JStr f) = Sat.JStr f - go (JRegEx f) = Sat.JRegEx f - go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) - go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,8 +134,7 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m 1) + satJStat (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] let oi = ObjUnit @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = satJStat (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,8 +245,7 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m n) + satJStat (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps let oi = ObjUnit @@ -336,7 +334,7 @@ genToplevelRhs i rhs = case rhs of eid@(TxtI eidt) <- identForEntryId i (TxtI idt) <- identForId i body <- genBody (initExprCtx i) R2 args body typ - global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body) + global_occs <- globalOccs (satJStat (Just "ghcjs_tmp_sat_") body) let lidents = map global_ident global_occs let lids = map global_id global_occs let lidents' = map identFS lidents ===================================== compiler/GHC/StgToJS/CoreUtils.hs ===================================== @@ -253,7 +253,7 @@ assocPrimReps (r:rs) vs = case (primRepSize r,vs) of (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs - err -> pprPanic "assocPrimReps" (ppr $ fmap (map satJExpr) $ err) + err -> pprPanic "assocPrimReps" (ppr $ map (satJExpr Nothing) <$> err) -- | Associate the given values to the Id's PrimReps, taking into account the -- number of slots per PrimRep ===================================== compiler/GHC/StgToJS/DataCon.hs ===================================== @@ -60,8 +60,8 @@ genCon ctx con args | xs <- concatMap typex_expr (ctxTarget ctx) = pprPanic "genCon: unhandled DataCon" (ppr (con - , fmap satJExpr args - , fmap satJExpr xs + , satJExpr Nothing <$> args + , satJExpr Nothing <$> xs )) -- | Allocate a data constructor. Allocate in this context means bind the data @@ -90,7 +90,7 @@ allocUnboxedCon con = \case | isBoolDataCon con && dataConTag con == 2 -> true_ [x] | isUnboxableCon con -> x - xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, fmap satJExpr xs)) + xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, satJExpr Nothing <$> xs)) -- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -900,7 +900,7 @@ caseCond = \case DataAlt da -> return $ Just (toJExpr $ dataConTag da) LitAlt l -> genLit l >>= \case [e] -> pure (Just e) - es -> pprPanic "caseCond: expected single-variable literal" (ppr $ fmap satJExpr es) + es -> pprPanic "caseCond: expected single-variable literal" (ppr $ satJExpr Nothing <$> es) -- fixme use single tmp var for all branches -- | Load parameters from constructor ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,8 +177,8 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a -saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) +saturateFFI :: Int -> JStat -> Sat.JStat +saturateFFI u = satJStat (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack => ExprCtx ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (satJStat Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) @@ -180,4 +181,4 @@ globalOccs jst = do let g = GlobalOcc i gid 1 in go (addToUFM_C inc gids i g) is - pure $ go emptyUFM (identsS $ satJStat jst) + pure $ go emptyUFM (identsS jst) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,8 +299,8 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat -rtsDecls = jsSaturate (Just "h$RTSD") $ +rtsDecls :: Sat.JStat +rtsDecls = satJStat (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread , TxtI "h$sp" ||= 0 -- stack pointer for the current thread @@ -314,15 +315,15 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat -rts = jsSaturate (Just "h$RTS") . rts' +rts :: StgToJSConfig -> Sat.JStat +rts = satJStat (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. rts' :: StgToJSConfig -> JStat View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/092d2d82f053359cc29275b9ba21272395bf16e1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/092d2d82f053359cc29275b9ba21272395bf16e1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 10:40:00 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Thu, 04 May 2023 06:40:00 -0400 Subject: [Git][ghc/ghc][wip/unitidset] Refactor `Set UnitId` to `UniqDSet UnitId` (#23335) Message-ID: <64538b80e3096_e3e0651f041385f3@gitlab.mail> Josh Meredith pushed to branch wip/unitidset at Glasgow Haskell Compiler / GHC Commits: ddbb211e by Josh Meredith at 2023-05-04T10:39:38+00:00 Refactor `Set UnitId` to `UniqDSet UnitId` (#23335) - - - - - 21 changed files: - compiler/GHC.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Types/Unique/DSet.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -395,6 +395,7 @@ import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -418,8 +419,6 @@ import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as S import qualified Data.Sequence as Seq import System.Directory @@ -604,7 +603,7 @@ setSessionDynFlags dflags0 = do logger <- getLogger dflags <- checkNewDynFlags logger dflags0 let all_uids = hsc_all_home_unit_ids hsc_env - case S.toList all_uids of + case uniqDSetToList all_uids of [uid] -> do setUnitDynFlagsNoCheck uid dflags modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags)) @@ -1379,7 +1378,7 @@ data ModuleInfo = ModuleInfo { -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do - if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env + if moduleUnitId mdl `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env then liftIO $ getHomeModuleInfo hsc_env mdl else liftIO $ getPackageModuleInfo hsc_env mdl @@ -1756,7 +1755,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, UnitIdSet) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -56,12 +56,11 @@ import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) +import GHC.Types.Unique.DSet import System.Directory import System.FilePath import System.IO -import Data.Set (Set) -import qualified Data.Set as Set {- ************************************************************************ @@ -84,7 +83,7 @@ codeOutput -> (a -> ForeignStubs) -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with the C compiler - -> Set UnitId -- ^ Dependencies + -> UnitIdSet -- ^ Dependencies -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), @@ -161,11 +160,11 @@ outputC :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a - -> Set UnitId + -> UnitIdSet -> IO a outputC logger dflags filenm cmm_stream unit_deps = withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do - let pkg_names = map unitIdString (Set.toAscList unit_deps) + let pkg_names = map unitIdString (uniqDSetToAscList unit_deps) doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h "#include \"Stg.h\"\n" ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -127,7 +127,7 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env -hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId +hsc_all_home_unit_ids :: HscEnv -> UnitIdSet hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -245,6 +245,7 @@ import GHC.Types.Name.Ppr import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic @@ -274,7 +275,6 @@ import Data.IORef import System.FilePath as FilePath import System.Directory import qualified Data.Set as S -import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) @@ -1457,15 +1457,15 @@ checkSafeImports tcg_env clearDiagnostics -- Check safe imports are correct - safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safePkgs <- mkUniqDSet <$> mapMaybeM checkSafe safeImps safeErrs <- getDiagnostics clearDiagnostics -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyMessages, S.empty) - True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + False -> return (emptyMessages, emptyUniqDSet) + True -> do infPkgs <- mkUniqDSet <$> mapMaybeM checkSafe regImps infErrs <- getDiagnostics clearDiagnostics return (infErrs, infPkgs) @@ -1516,12 +1516,12 @@ checkSafeImports tcg_env checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> + pkgTrustReqs :: DynFlags -> UnitIdSet -> UnitIdSet -> Bool -> ImportAvails pkgTrustReqs dflags req inf infPassed | safeInferOn dflags && not (safeHaskellModeEnabled dflags) && infPassed = emptyImportAvails { - imp_trust_pkgs = req `S.union` inf + imp_trust_pkgs = req `unionUniqDSets` inf } pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe = emptyImportAvails @@ -1540,12 +1540,12 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyMessages errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, UnitIdSet) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l good <- isEmptyMessages `fmap` getDiagnostics clearDiagnostics -- don't want them printed... - let pkgs' | Just p <- self = S.insert p pkgs + let pkgs' | Just p <- self = addOneToUniqDSet pkgs p | otherwise = pkgs return (good, pkgs') @@ -1554,7 +1554,7 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe UnitId, Set UnitId) + -> Hsc (Maybe UnitId, UnitIdSet) hscCheckSafe' m l = do hsc_env <- getHscEnv let home_unit = hsc_home_unit hsc_env @@ -1566,7 +1566,7 @@ hscCheckSafe' m l = do -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) where - isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) + isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, UnitIdSet) isModSafe home_unit m l = do hsc_env <- getHscEnv dflags <- getDynFlags @@ -1648,10 +1648,10 @@ hscCheckSafe' m l = do -- | Check the list of packages are trusted. -checkPkgTrust :: Set UnitId -> Hsc () +checkPkgTrust :: UnitIdSet -> Hsc () checkPkgTrust pkgs = do hsc_env <- getHscEnv - let errors = S.foldr go emptyBag pkgs + let errors = foldr go emptyBag $ uniqDSetToList pkgs state = hsc_units hsc_env go pkg acc | unitIsTrusted $ unsafeLookupUnitId state pkg @@ -1699,7 +1699,7 @@ markUnsafeInfer tcg_env whyUnsafe = do False -> return tcg_env where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = emptyUniqDSet } pprMod = ppr $ moduleName $ tcg_mod tcg_env whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" @@ -2060,7 +2060,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs in NoStubs `appendStubC` ip_init | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] emptyUniqDSet rawCmms return stub_c_exists where ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -107,6 +107,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Types.PkgQual import GHC.Unit @@ -490,7 +491,7 @@ load how_much = loadWithCache noIfaceCache how_much mkBatchMsg :: HscEnv -> Messager mkBatchMsg hsc_env = - if length (hsc_all_home_unit_ids hsc_env) > 1 + if sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 -- This also displays what unit each module is from. then batchMultiMsg else batchMsg @@ -1735,25 +1736,25 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit. -checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages] +checkHomeUnitsClosed :: UnitEnv -> UnitIdSet -> [(UnitId, UnitId)] -> [DriverMessages] -- Fast path, trivially closed. checkHomeUnitsClosed ue home_id_set home_imp_ids - | Set.size home_id_set == 1 = [] + | sizeUniqDSet home_id_set == 1 = [] | otherwise = - let res = foldMap loop home_imp_ids + let res = foldr (\ids acc -> unionUniqDSets acc $ loop ids) emptyUniqDSet home_imp_ids -- Now check whether everything which transitively depends on a home_unit is actually a home_unit -- These units are the ones which we need to load as home packages but failed to do for some reason, -- it's a bug in the tool invoking GHC. - bad_unit_ids = Set.difference res home_id_set - in if Set.null bad_unit_ids + bad_unit_ids = res `minusUniqDSet` home_id_set + in if isEmptyUniqDSet bad_unit_ids then [] - else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (uniqDSetToAscList bad_unit_ids)] where rootLoc = mkGeneralSrcSpan (fsLit "") -- TODO: This could repeat quite a bit of work but I struggled to write this function. -- Which units transitively depend on a home unit - loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit + loop :: (UnitId, UnitId) -> UnitIdSet -- The units which transitively depend on a home unit loop (from_uid, uid) = let us = ue_findHomeUnitEnv from_uid ue in let um = unitInfoMap (homeUnitEnv_units us) in @@ -1761,20 +1762,21 @@ checkHomeUnitsClosed ue home_id_set home_imp_ids Nothing -> pprPanic "uid not found" (ppr uid) Just ui -> let depends = unitDepends ui - home_depends = Set.fromList depends `Set.intersection` home_id_set - other_depends = Set.fromList depends `Set.difference` home_id_set + home_depends = mkUniqDSet depends `intersectUniqDSets` home_id_set + other_depends = mkUniqDSet depends `minusUniqDSet` home_id_set in -- Case 1: The unit directly depends on a home_id - if not (null home_depends) + if not (isEmptyUniqDSet home_depends) then - let res = foldMap (loop . (from_uid,)) other_depends - in Set.insert uid res + let res :: UnitIdSet + res = foldr (\ide acc -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends + in addOneToUniqDSet res uid -- Case 2: Check the rest of the dependencies, and then see if any of them depended on else - let res = foldMap (loop . (from_uid,)) other_depends + let res = foldr (\ide acc -> acc `unionUniqDSets` loop (from_uid, ide)) emptyUniqDSet $ uniqDSetToList other_depends in - if not (Set.null res) - then Set.insert uid res + if not (isEmptyUniqDSet res) + then addOneToUniqDSet res uid else res -- | Update the every ModSummary that is depended on ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -108,6 +108,7 @@ import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.SourceError +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -125,7 +126,7 @@ import Control.Monad import qualified Control.Monad.Catch as MC (handle) import Data.Maybe import Data.Either ( partitionEithers ) -import qualified Data.Set as Set +import Data.List ( sort ) import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp @@ -408,8 +409,8 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt home_mod_infos = eltsHpt hpt -- the packages we depend on - pkg_deps = Set.toList - $ Set.unions + pkg_deps = uniqDSetToList + $ unionManyUniqDSets $ fmap (dep_direct_pkgs . mi_deps . hm_iface) $ home_mod_infos @@ -418,7 +419,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos)) debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) - debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps)) + debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr $ sort pkg_deps)) -- check for the -no-link flag if isNoLink (ghcLink dflags) ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Env @@ -40,7 +41,6 @@ import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.Set as Set import GHC.Linker.Types import GHC.Unit.Finder @@ -196,7 +196,7 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do mk_mod_usage_info :: UsageConfig -> HomeUnit - -> Set.Set UnitId + -> UnitIdSet -> Module -> ImportedMods -> NameSet @@ -255,7 +255,7 @@ mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names -- (need to recompile if its export list changes: export_fprint) mkUsage :: Module -> ModIface -> Maybe Usage mkUsage mod iface - | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids + | not $ toUnitId (moduleUnit mod) `elementOfUniqDSet` home_unit_ids = Just $ UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -504,7 +504,7 @@ loadInterface doc_str mod from -- overlapping instances. ; massertPpr ((isOneShot (ghcMode (hsc_dflags hsc_env))) - || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env + || not (moduleUnitId mod `elementOfUniqDSet` hsc_all_home_unit_ids hsc_env) || mod == gHC_PRIM) (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique.Set import GHC.Types.Fixity.Env import GHC.Types.Unique.Map +import GHC.Types.Unique.DSet import GHC.Unit.External import GHC.Unit.Finder import GHC.Unit.State @@ -617,8 +618,8 @@ checkDependencies hsc_env summary iface all_home_units = hsc_all_home_unit_ids hsc_env units = hsc_units hsc_env prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) - prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) - (dep_plugin_pkgs (mi_deps iface))) + prev_dep_pkgs = uniqDSetToAscList (unionUniqDSets (dep_direct_pkgs (mi_deps iface)) + (dep_plugin_pkgs (mi_deps iface))) implicit_deps = map (fsLit "Implicit",) (implicitPackageDeps dflags) @@ -633,7 +634,7 @@ checkDependencies hsc_env summary iface classify _ (Found _ mod) - | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) + | (toUnitId $ moduleUnit mod) `elementOfUniqDSet` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -324,20 +324,20 @@ loadCmdLineLibs interp hsc_env = do loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState loadCmdLineLibs' interp hsc_env pls = snd <$> foldM - (\(done', pls') cur_uid -> load done' cur_uid pls') - (Set.empty, pls) - (hsc_all_home_unit_ids hsc_env) + (\(done', pls') cur_uid -> load done' cur_uid pls') + (emptyUniqDSet, pls) + (uniqDSetToList $ hsc_all_home_unit_ids hsc_env) where - load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState) - load done uid pls | uid `Set.member` done = return (done, pls) + load :: UnitIdSet -> UnitId -> LoaderState -> IO (UnitIdSet, LoaderState) + load done uid pls | uid `elementOfUniqDSet` done = return (done, pls) load done uid pls = do let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (homeUnitDepends (hsc_units hsc')) pls'' <- loadCmdLineLibs'' interp hsc' pls' - return $ (Set.insert uid done', pls'') + return $ (addOneToUniqDSet done' uid, pls'') loadCmdLineLibs'' :: Interp @@ -685,7 +685,7 @@ getLinkDeps :: HscEnv -> Maybe FilePath -- replace object suffixes? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first + -> IO ([Linkable], [Linkable], [UnitId], UnitIdSet) -- ... then link these first -- The module and package dependencies for the needed modules are returned. -- See Note [Object File Dependencies] -- Fails with an IO exception if it can't find enough files @@ -737,7 +737,7 @@ getLinkDeps hsc_env pls replace_osuf span mods -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop :: (UnitIdSet, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UnitIdSet, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts @@ -766,7 +766,7 @@ getLinkDeps hsc_env pls replace_osuf span mods HsBootFile -> link_boot_mod_error (mi_module iface) _ -> return $ Just (mi_module iface) - in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod + in (dep_direct_pkgs (mi_deps iface),) <$> mmod Nothing -> let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid in throwGhcExceptionIO (ProgramError (showSDoc dflags err)) @@ -780,9 +780,9 @@ getLinkDeps hsc_env pls replace_osuf span mods -- dependencies of that. Hence we need to traverse the dependency -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow - -> UniqDSet Module -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([Module], UniqDSet UnitId) -- result + -> UniqDSet Module -- accum. module dependencies + -> UnitIdSet -- accum. package dependencies + -> IO ([Module], UnitIdSet) -- result follow_deps [] acc_mods acc_pkgs = return (uniqDSetToList acc_mods, acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -814,7 +814,7 @@ getLinkDeps hsc_env pls replace_osuf span mods acc_mods' = case hsc_home_unit_maybe hsc_env of Nothing -> acc_mods Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs (uniqDSetToList pkg_deps) case hsc_home_unit_maybe hsc_env of Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -37,7 +37,7 @@ module GHC.Linker.Types where import GHC.Prelude -import GHC.Unit ( UnitId, Module ) +import GHC.Unit ( UnitId, Module, UnitIdSet ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) import GHCi.RemoteTypes ( ForeignHValue ) @@ -53,7 +53,6 @@ import Control.Concurrent.MVar import Data.Time ( UTCTime ) import Data.Maybe import GHC.Unit.Module.Env -import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM import GHC.Unit.Module.WholeCoreBindings @@ -146,7 +145,7 @@ data LoadedPkgInfo { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] - , loaded_pkg_trans_deps :: UniqDSet UnitId + , loaded_pkg_trans_deps :: UnitIdSet } instance Outputable LoadedPkgInfo where ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -74,6 +74,7 @@ import GHC.Types.Id import GHC.Types.HpcInfo import GHC.Types.PkgQual import GHC.Types.GREInfo (ConInfo(..)) +import GHC.Types.Unique.DSet import GHC.Unit import GHC.Unit.Module.Warnings @@ -212,8 +213,8 @@ rnImports imports = do let merged_import_avail = clobberSourceImports imp_avails dflags <- getDynFlags let final_import_avail = - merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags) - `S.union` imp_dep_direct_pkgs merged_import_avail} + merged_import_avail { imp_dep_direct_pkgs = mkUniqDSet (implicitPackageDeps dflags) + `unionUniqDSets` imp_dep_direct_pkgs merged_import_avail} return (decls, rdr_env, final_import_avail, hpc_usage) where @@ -480,7 +481,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. calculateAvails :: HomeUnit - -> S.Set UnitId + -> UnitIdSet -> ModIface -> IsSafeImport -> IsBootInterface @@ -535,7 +536,7 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by -- Trusted packages are a lot like orphans. trusted_pkgs | mod_safe' = dep_trusted_pkgs deps - | otherwise = S.empty + | otherwise = emptyUniqDSet pkg = moduleUnit (mi_module iface) @@ -548,11 +549,11 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by | isHomeUnit home_unit pkg = ptrust | otherwise = False - dependent_pkgs = if toUnitId pkg `S.member` other_home_units - then S.empty - else S.singleton ipkg + dependent_pkgs = if toUnitId pkg `elementOfUniqDSet` other_home_units + then emptyUniqDSet + else unitUniqDSet ipkg - direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units + direct_mods = mkModDeps $ if toUnitId pkg `elementOfUniqDSet` other_home_units then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) else S.empty ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -148,6 +148,7 @@ import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -185,7 +186,6 @@ import Data.List ( sortBy, sort ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.Ord -import qualified Data.Set as S import Data.Traversable ( for ) @@ -3134,7 +3134,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , text "Dependent modules:" <+> (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_direct_pkgs imports)] + ppr (uniqDSetToAscList $ imp_dep_direct_pkgs imports)] -- The use of sort is just to reduce unnecessary -- wobbling in testsuite output ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -142,6 +142,7 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo @@ -1367,9 +1368,9 @@ plusModDeps = plusInstalledModuleEnv plus_mod_dep emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, imp_direct_dep_mods = emptyInstalledModuleEnv, - imp_dep_direct_pkgs = S.empty, + imp_dep_direct_pkgs = emptyUniqDSet, imp_sig_mods = [], - imp_trust_pkgs = S.empty, + imp_trust_pkgs = emptyUniqDSet, imp_trust_own_pkg = False, imp_boot_mods = emptyInstalledModuleEnv, imp_orphs = [], @@ -1398,8 +1399,8 @@ plusImportAvails imp_orphs = orphs2, imp_finsts = finsts2 }) = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2, - imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, - imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, + imp_dep_direct_pkgs = ddpkgs1 `unionUniqDSets` ddpkgs2, + imp_trust_pkgs = tpkgs1 `unionUniqDSets` tpkgs2, imp_trust_own_pkg = tself1 || tself2, imp_boot_mods = srs1 `plusModDeps` srcs2, imp_sig_mods = unionListsOrd sig_mods1 sig_mods2, ===================================== compiler/GHC/Types/Unique/DSet.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Types.Unique.DSet ( isEmptyUniqDSet, lookupUniqDSet, uniqDSetToList, + uniqDSetToAscList, partitionUniqDSet, mapUniqDSet ) where @@ -43,8 +44,11 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique +import GHC.Utils.Binary + import Data.Coerce import Data.Data +import Data.List (sort) -- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. -- Beyond preserving invariants, we may also want to 'override' typeclass @@ -120,6 +124,9 @@ lookupUniqDSet = lookupUDFM . getUniqDSet uniqDSetToList :: UniqDSet a -> [a] uniqDSetToList = eltsUDFM . getUniqDSet +uniqDSetToAscList :: Ord a => UniqDSet a -> [a] +uniqDSetToAscList = sort . uniqDSetToList + partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet @@ -140,3 +147,7 @@ instance Outputable a => Outputable (UniqDSet a) where pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList + +instance (Uniquable a, Binary a, Ord a) => Binary (UniqDSet a) where + put_ bh = put_ bh . uniqDSetToAscList + get bh = mkUniqDSet <$> get bh ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -81,6 +81,7 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Panic (pprPanic) +import GHC.Types.Unique.DSet import GHC.Unit.Module.ModIface import GHC.Unit.Module import qualified Data.Set as Set @@ -339,8 +340,8 @@ unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env -unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey -unitEnv_keys env = Map.keysSet (unitEnv_graph env) +unitEnv_keys :: UnitEnvGraph v -> UnitIdSet +unitEnv_keys env = mkUniqDSet $ Map.keys (unitEnv_graph env) unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)] unitEnv_elts env = Map.toList (unitEnv_graph env) @@ -443,7 +444,7 @@ ue_unitHomeUnit_maybe uid ue_env = ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env -ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId +ue_all_home_unit_ids :: UnitEnv -> UnitIdSet ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.State +import GHC.Types.Unique.DSet import GHC.Utils.Fingerprint import GHC.Utils.Binary @@ -53,13 +54,13 @@ data Dependencies = Deps -- ^ All home-package modules which are directly imported by this one. -- This may include modules from other units when using multiple home units - , dep_direct_pkgs :: Set UnitId + , dep_direct_pkgs :: UnitIdSet -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. -- Does not include other home units when using multiple home units. -- Modules from these units will go in `dep_direct_mods` - , dep_plugin_pkgs :: Set UnitId + , dep_plugin_pkgs :: UnitIdSet -- ^ All units needed for plugins ------------------------------------ @@ -69,7 +70,7 @@ data Dependencies = Deps -- ^ Transitive closure of hsig files in the home package - , dep_trusted_pkgs :: Set UnitId + , dep_trusted_pkgs :: UnitIdSet -- Packages which we are required to trust -- when the module is imported as a safe import -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names @@ -110,7 +111,7 @@ data Dependencies = Deps mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies mkDependencies home_unit mod imports plugin_mods = let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods - plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins) + plugin_units = mkUniqDSet (map (toUnitId . moduleUnit) external_plugins) all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot)) (imp_direct_dep_mods imports) (map (fmap toUnitId) home_plugins) @@ -197,12 +198,12 @@ instance Binary Dependencies where noDependencies :: Dependencies noDependencies = Deps - { dep_direct_mods = Set.empty - , dep_direct_pkgs = Set.empty - , dep_plugin_pkgs = Set.empty + { dep_direct_mods = mempty + , dep_direct_pkgs = emptyUniqDSet + , dep_plugin_pkgs = emptyUniqDSet , dep_sig_mods = [] - , dep_boot_mods = Set.empty - , dep_trusted_pkgs = Set.empty + , dep_boot_mods = mempty + , dep_trusted_pkgs = emptyUniqDSet , dep_orphs = [] , dep_finsts = [] } @@ -220,11 +221,11 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, text "boot module dependencies:" <+> ppr_set ppr bmods, - text "direct package dependencies:" <+> ppr_set ppr pkgs, - text "plugin package dependencies:" <+> ppr_set ppr plgns, - if null tps + text "direct package dependencies:" <+> ppr_unitIdSet ppr pkgs, + text "plugin package dependencies:" <+> ppr_unitIdSet ppr plgns, + if isEmptyUniqDSet tps then empty - else text "trusted package dependencies:" <+> ppr_set ppr tps, + else text "trusted package dependencies:" <+> ppr_unitIdSet ppr tps, text "orphans:" <+> fsep (map ppr orphs), text "family instance modules:" <+> fsep (map ppr finsts) ] @@ -235,6 +236,9 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc ppr_set w = fsep . fmap w . Set.toAscList + ppr_unitIdSet :: (UnitId -> SDoc) -> UnitIdSet -> SDoc + ppr_unitIdSet w = fsep . fmap w . sort . uniqDSetToList + -- | Records modules for which changes may force recompilation of this module -- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance -- @@ -491,7 +495,7 @@ data ImportAvails imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot, -- ^ Home-package modules directly imported by the module being compiled. - imp_dep_direct_pkgs :: Set UnitId, + imp_dep_direct_pkgs :: UnitIdSet, -- ^ Packages directly needed by the module being compiled imp_trust_own_pkg :: Bool, @@ -502,7 +506,7 @@ data ImportAvails -- Transitive information below here - imp_trust_pkgs :: Set UnitId, + imp_trust_pkgs :: UnitIdSet, -- ^ This records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if ===================================== compiler/GHC/Unit/Module/ModGuts.hs ===================================== @@ -37,8 +37,6 @@ import GHC.Types.SourceFile ( HscSource(..), hscSourceToIsBoot ) import GHC.Types.SrcLoc import GHC.Types.CostCentre -import Data.Set (Set) - -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module @@ -137,7 +135,7 @@ data CgGuts cg_ccs :: [CostCentre], -- List of cost centres used in bindings and rules cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_foreign_files :: ![(ForeignSrcLang, FilePath)], - cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to + cg_dep_pkgs :: !UnitIdSet, -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -346,10 +346,10 @@ data UnitConfig = UnitConfig , unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units , unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units , unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units - , unitConfigHomeUnits :: Set.Set UnitId + , unitConfigHomeUnits :: UnitIdSet } -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig +initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> UnitConfig initUnitConfig dflags cached_dbs home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags @@ -626,7 +626,7 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> UnitIdSet -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) initUnits logger dflags cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () @@ -1362,7 +1362,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> text db_path - forM_ (Set.toList override_set) $ \pkg -> + forM_ (uniqDSetToList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> text "overrides a previously defined package" @@ -1374,9 +1374,9 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] -- The set of UnitIds which appear in both db and pkgs. These are the -- ones that get overridden. Compute this just to give some -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) + override_set :: UnitIdSet + override_set = intersectUniqDSets (mkUniqDSet $ nonDetKeysUniqMap db_map) + (mkUniqDSet $ nonDetKeysUniqMap pkg_map) -- Now merge the sets together (NB: in case of duplicate, -- first argument preferred) @@ -1688,7 +1688,7 @@ mkUnitState logger cfg = do let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = uniqDSetToList home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map @@ -1701,15 +1701,15 @@ mkUnitState logger cfg = do } return (state, raw_dbs) -selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool -selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True +selectHptFlag :: UnitIdSet -> PackageFlag -> Bool +selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = True selectHptFlag _ _ = False -selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId -selectHomeUnits home_units flags = foldl' go Set.empty flags +selectHomeUnits :: UnitIdSet -> [PackageFlag] -> UnitIdSet +selectHomeUnits home_units flags = foldl' go emptyUniqDSet flags where - go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId - go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur + go :: UnitIdSet -> PackageFlag -> UnitIdSet + go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `elementOfUniqDSet` home_units = addOneToUniqDSet cur (toUnitId uid) -- MP: This does not yet support thinning/renaming go cur _ = cur ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -33,6 +33,7 @@ module GHC.Unit.Types , GenInstantiatedUnit (..) , InstantiatedUnit , DefUnitId + , UnitIdSet , Instantiations , GenInstantiations , mkInstantiatedUnit @@ -538,6 +539,8 @@ pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- code for. type DefUnitId = Definite UnitId +type UnitIdSet = UniqDSet UnitId + unitIdString :: UnitId -> String unitIdString = unpackFS . unitIdFS ===================================== ghc/GHCi/UI.hs ===================================== @@ -105,6 +105,7 @@ import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Bag (unitBag) import qualified GHC.Data.Strict as Strict +import GHC.Types.Unique.DSet -- Haskell Libraries import System.Console.Haskeline as Haskeline @@ -125,7 +126,6 @@ import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.List.NonEmpty as NE -import qualified Data.Set as S import Data.Maybe import qualified Data.Map as M import Data.IntMap.Strict (IntMap) @@ -561,7 +561,7 @@ interactiveUI config srcs maybe_exprs = do -- Set to True because Prelude is implicitly imported. impDecl at ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}} hsc_env <- GHC.getSession - let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1 + let in_multi = sizeUniqDSet (hsc_all_home_unit_ids hsc_env) > 1 empty_cache <- liftIO newIfaceCache startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, @@ -2568,15 +2568,15 @@ isSafeModule m = do -- print info to user... liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") - when (not $ S.null good) + when (not $ isEmptyUniqDSet good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ - (intercalate ", " $ map (showPpr dflags) (S.toList good))) - case msafe && S.null bad of + (intercalate ", " $ map (showPpr dflags) (uniqDSetToList good))) + case msafe && isEmptyUniqDSet bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do - when (not $ null bad) + when (not $ isEmptyUniqDSet bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " - ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad))) + ++ (intercalate ", " $ map (showPpr dflags) (uniqDSetToList bad))) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where @@ -2586,8 +2586,8 @@ isSafeModule m = do | isHomeModule (hsc_home_unit hsc_env) md = True | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md) - tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty) - | otherwise = S.partition part deps + tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (emptyUniqDSet, emptyUniqDSet) + | otherwise = partitionUniqDSet part deps where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg unit_state = hsc_units hsc_env dflags = hsc_dflags hsc_env View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ddbb211eb3625cfbc8fe5a7f55fef1ee2cea34d8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ddbb211eb3625cfbc8fe5a7f55fef1ee2cea34d8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 11:21:54 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Thu, 04 May 2023 07:21:54 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/t23221 Message-ID: <645395524e07a_e3e063a20fc814733@gitlab.mail> Matthew Pickering pushed new branch wip/t23221 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/t23221 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 14:28:13 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 10:28:13 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6453c0fd4978d_e3e063a20fc8196449@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: fbd74575 by Matthew Pickering at 2023-05-04T10:27:53-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 5b0cd6ef by romes at 2023-05-04T10:27:53-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 8838f72d by romes at 2023-05-04T10:27:53-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db41b5c7 by romes at 2023-05-04T10:27:53-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - b7e6f986 by Matthew Pickering at 2023-05-04T10:27:53-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 8aad6409 by Josh Meredith at 2023-05-04T10:27:54-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - a3784070 by Sylvain Henry at 2023-05-04T10:27:54-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - da3458d5 by Luite Stegeman at 2023-05-04T10:27:58-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - 17593bd2 by Josh Meredith at 2023-05-04T10:27:59-04:00 base/encoding: add an allocations performance test (#22946) - - - - - 578a0500 by Krzysztof Gogolewski at 2023-05-04T10:27:59-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 236c2947 by Andrei Borzenkov at 2023-05-04T10:28:04-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 69c7254e by Ryan Scott at 2023-05-04T10:28:04-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 18 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75b31dbc2db28816883e6ec1bc5a573c14b3d0e7...69c7254e382f9ac2b5eaa01cd83a31543fa3cb8a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75b31dbc2db28816883e6ec1bc5a573c14b3d0e7...69c7254e382f9ac2b5eaa01cd83a31543fa3cb8a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 14:53:47 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Thu, 04 May 2023 10:53:47 -0400 Subject: [Git][ghc/ghc][wip/23305] 3 commits: Fix behaviour of -keep-tmp-files when used in OPTIONS_GHC pragma Message-ID: <6453c6fbb0797_e3e0651f042236d1@gitlab.mail> Matthew Pickering pushed to branch wip/23305 at Glasgow Haskell Compiler / GHC Commits: 306ad553 by Matthew Pickering at 2023-05-04T15:53:37+01:00 Fix behaviour of -keep-tmp-files when used in OPTIONS_GHC pragma This fixes the behaviour of -keep-tmp-files when used in an OPTIONS_GHC pragma for files with module level scope. Instead of simple not deleting the files, we also need to remove them from the TmpFs so they are not deleted later on when all the other files are deleted. There are additional complications because you also need to remove the directory where these files live from the TmpFs so we don't try to delete those later either. I added two tests. 1. Tests simply that -keep-tmp-files works at all with a single module and --make mode. 2. The other tests that temporary files are deleted for other modules which don't enable -keep-tmp-files. Fixes #23339 - - - - - 2d6d27de by Matthew Pickering at 2023-05-04T15:53:37+01:00 withDeferredDiagnostics: When debugIsOn, write landmine into IORef to catch use-after-free. Ticket #23305 reports an error where we were attempting to use the logger which was created by withDeferredDiagnostics after its scope had ended. This problem would have been caught by this patch and a validate build: ``` +*** Exception: Use after free +CallStack (from HasCallStack): + error, called at compiler/GHC/Driver/Make.hs:<line>:<column> in <package-id>:GHC.Driver.Make ``` This general issue is tracked by #20981 - - - - - 384c9a2f by Matthew Pickering at 2023-05-04T15:53:37+01:00 Don't return complete HscEnv from upsweep By returning a complete HscEnv from upsweep the logger (as introduced by withDeferredDiagnostics) was escaping the scope of withDeferredDiagnostics and hence we were losing error messages. This is reminiscent of #20981, which also talks about writing errors into messages after their scope has ended. See #23305 for details. - - - - - 9 changed files: - compiler/GHC/Driver/Make.hs - compiler/GHC/Utils/TmpFs.hs - testsuite/tests/driver/Makefile - + testsuite/tests/driver/T23339.hs - + testsuite/tests/driver/T23339.stdout - + testsuite/tests/driver/T23339B.hs - + testsuite/tests/driver/T23339B.stdout - testsuite/tests/driver/all.T - testsuite/tests/ghci/prog018/prog018.stdout Changes: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -772,16 +772,14 @@ load' mhmi_cache how_much mHscMessage mod_graph = do worker_limit <- liftIO $ mkWorkerLimit dflags setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env - (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ do + (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do hsc_env <- getSession liftIO $ upsweep worker_limit hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan - setSession hsc_env1 + modifySession (addDepsToHscEnv new_deps) case upsweep_ok of Failed -> loadFinish upsweep_ok Succeeded -> do liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.") - -- Clean up after ourselves - liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags loadFinish upsweep_ok @@ -1250,14 +1248,13 @@ upsweep -> Maybe Messager -> M.Map ModNodeKeyWithUid HomeModInfo -> [BuildPlan] - -> IO (SuccessFlag, HscEnv) + -> IO (SuccessFlag, [HomeModInfo]) upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan runPipelines n_jobs hsc_env mHscMessage pipelines res <- collect_result let completed = [m | Just (Just m) <- res] - let hsc_env' = addDepsToHscEnv completed hsc_env -- Handle any cycle in the original compilation graph and return the result -- of the upsweep. @@ -1265,10 +1262,10 @@ upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do Just mss -> do let logger = hsc_logger hsc_env liftIO $ fatalErrorMsg logger (cyclicModuleErr mss) - return (Failed, hsc_env) + return (Failed, []) Nothing -> do let success_flag = successIf (all isJust res) - return (success_flag, hsc_env') + return (success_flag, completed) toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis]) @@ -2331,18 +2328,21 @@ withDeferredDiagnostics f = do let action = logMsg logger msgClass srcSpan msg case msgClass of MCDiagnostic SevWarning _reason _code - -> atomicModifyIORef' warnings $ \i -> (action: i, ()) + -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) MCDiagnostic SevError _reason _code - -> atomicModifyIORef' errors $ \i -> (action: i, ()) + -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) MCFatal - -> atomicModifyIORef' fatals $ \i -> (action: i, ()) + -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) _ -> action printDeferredDiagnostics = liftIO $ forM_ [warnings, errors, fatals] $ \ref -> do -- This IORef can leak when the dflags leaks, so let us always - -- reset the content. - actions <- atomicModifyIORef' ref $ \i -> ([], i) + -- reset the content. The lazy variant is used here as we want to force + -- this error if the IORef is ever accessed again, rather than now. + -- See #20981 for an issue which discusses this general issue. + let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else [] + actions <- atomicModifyIORef ref $ \i -> (landmine, i) sequence_ $ reverse actions MC.bracket @@ -2418,8 +2418,9 @@ cyclicModuleErr mss cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () cleanCurrentModuleTempFilesMaybe logger tmpfs dflags = - unless (gopt Opt_KeepTmpFiles dflags) $ - liftIO $ cleanCurrentModuleTempFiles logger tmpfs + if gopt Opt_KeepTmpFiles dflags + then liftIO $ keepCurrentModuleTempFiles logger tmpfs + else liftIO $ cleanCurrentModuleTempFiles logger tmpfs addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv ===================================== compiler/GHC/Utils/TmpFs.hs ===================================== @@ -13,6 +13,7 @@ module GHC.Utils.TmpFs , cleanTempDirs , cleanTempFiles , cleanCurrentModuleTempFiles + , keepCurrentModuleTempFiles , addFilesToClean , changeTempFilesLifetime , newTempName @@ -172,6 +173,32 @@ cleanTempFiles logger tmpfs , Set.toList cm_paths ++ Set.toList gs_paths) remove to_delete +-- | Keep all the paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@ +-- that have lifetime TFL_CurrentModule. This function is used when `-keep-tmp-files` is +-- used in an OPTIONS_GHC pragma. +-- This function removes the temporary file from the TmpFs so we no longer remove +-- it at the env when cleanTempFiles is called. +keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO () +keepCurrentModuleTempFiles logger tmpfs + = mask_ + $ do to_keep_files <- keep (tmp_files_to_clean tmpfs) + to_keep_subdirs <- keep (tmp_subdirs_to_clean tmpfs) + -- Remove any folders which contain any files we want to keep from the + -- directories we are tracking. A new temporary directory will be created + -- the next time a temporary file is needed (by perhaps another module). + keepDirs (to_keep_files ++ to_keep_subdirs) (tmp_dirs_to_clean tmpfs) + where + keepDirs keeps ref = do + let keep_dirs = Set.fromList (map takeDirectory keeps) + atomicModifyIORef' ref $ \m -> (Map.filter (\fp -> fp `Set.notMember` keep_dirs) m, ()) + + keep ref = do + to_keep <- atomicModifyIORef' ref $ + \ptc at PathsToClean{ptcCurrentModule = cm_paths} -> + (ptc {ptcCurrentModule = Set.empty}, Set.toList cm_paths) + debugTraceMsg logger 2 (text "Keeping:" <+> hsep (map text to_keep)) + return to_keep + -- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@ -- That have lifetime TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a ===================================== testsuite/tests/driver/Makefile ===================================== @@ -792,4 +792,21 @@ T22669: ! test -f T22669.o-boot +T23339: + $(RM) T23339.hi + $(RM) T23339$(OBJSUFFIX) + $(RM) -rf "$(PWD)/tmp" + mkdir -p tmp + TMPDIR="$(PWD)/tmp" "$(TEST_HC)" $(TEST_HC_OPTS) -v0 T23339.hs + find . -name "*.c" -exec cat {} \; | grep "init__ip_init" + +T23339B: + $(RM) T23339.hi + $(RM) T23339$(OBJSUFFIX) + $(RM) -rf "$(PWD)/tmp" + mkdir -p tmp + TMPDIR="$(PWD)/tmp" "$(TEST_HC)" $(TEST_HC_OPTS) -v0 T23339B.hs -finfo-table-map + # Check that the file is kept and is the right one + find . -name "*.c" -exec cat {} \; | grep "init__ip_init" + ===================================== testsuite/tests/driver/T23339.hs ===================================== @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -keep-tmp-files -finfo-table-map #-} +module T23339 where + +defn = id "T23339" ===================================== testsuite/tests/driver/T23339.stdout ===================================== @@ -0,0 +1 @@ +void T23339_init__ip_init (void) ===================================== testsuite/tests/driver/T23339B.hs ===================================== @@ -0,0 +1,5 @@ +module T23339B where + +import T23339 + +qux = id "abc" ===================================== testsuite/tests/driver/T23339B.stdout ===================================== @@ -0,0 +1 @@ +void T23339_init__ip_init (void) ===================================== testsuite/tests/driver/all.T ===================================== @@ -320,3 +320,5 @@ test('T22044', normal, makefile_test, []) test('T22048', [only_ways(['normal']), grep_errmsg("_rule")], compile, ["-O -fomit-interface-pragmas -ddump-simpl"]) test('T21722', normal, compile_fail, ['-fno-show-error-context']) test('T22669', js_skip, makefile_test, []) +test('T23339', js_skip, makefile_test, []) +test('T23339B', [extra_files(['T23339.hs']), js_skip], makefile_test, []) ===================================== testsuite/tests/ghci/prog018/prog018.stdout ===================================== @@ -19,4 +19,7 @@ C.hs:6:7: error: [GHC-88464] Variable not in scope: variableNotInScope :: () Failed, two modules loaded. [3 of 3] Compiling C ( C.hs, interpreted ) + +C.hs:6:7: error: [GHC-88464] + Variable not in scope: variableNotInScope :: () Failed, two modules loaded. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/90045770e4b744ac5793dce0aafd651677378265...384c9a2f0ce460d2f167f2dfc9fe6d823db580e4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/90045770e4b744ac5793dce0aafd651677378265...384c9a2f0ce460d2f167f2dfc9fe6d823db580e4 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 17:25:44 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Thu, 04 May 2023 13:25:44 -0400 Subject: [Git][ghc/ghc][wip/decode_cloned_stack] 2 commits: Add missing bang patterns to StackFrames Message-ID: <6453ea9852bec_e3e063c09fc4247045@gitlab.mail> Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC Commits: 8420e1d7 by Sven Tennie at 2023-05-04T16:19:55+00:00 Add missing bang patterns to StackFrames - - - - - 03425236 by Sven Tennie at 2023-05-04T17:25:00+00:00 Try more general data structure - - - - - 2 changed files: - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs Changes: ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -20,8 +20,12 @@ module GHC.Exts.Heap.Closures ( , closureSize -- * Stack - , StgStackClosure(..) - , StackFrame(..) + , StgStackClosure + , GenStgStackClosure(..) + , StackFrame + , GenStackFrame(..) + , StackField + , GenStackField(..) -- * Boxes , Box(..) @@ -374,54 +378,63 @@ data GenClosure b -- primitives and one for closures. This turned out to be a nightmare with lots -- of pattern matches and leaking data structures to enable access to primitives -- on the stack... -data StgStackClosure = StgStackClosure +type StgStackClosure = GenStgStackClosure Box + +data GenStgStackClosure b = GenStgStackClosure { ssc_info :: !StgInfoTable , ssc_stack_size :: !Word32 -- ^ stack size in *words* , ssc_stack_dirty :: !Word8 -- ^ non-zero => dirty , ssc_stack_marking :: !Word8 - , ssc_stack :: ![StackFrame] + , ssc_stack :: ![GenStackFrame b] } - deriving Show + deriving (Show, Generic) + +type StackField = GenStackField Box + +data GenStackField b + -- | A non-pointer field + = StackWord !Word + -- | A pointer field + | StackBox !b + deriving (Show, Generic) + +type StackFrame = GenStackFrame Box -- | A single stack frame --- --- It doesn't use `Box`es because that would require a `Box` constructor for --- primitive values (bitmap encoded payloads), which introduces lots of pattern --- matches and complicates the whole implementation (and breaks existing code.) -data StackFrame = +data GenStackFrame b = UpdateFrame { info_tbl :: !StgInfoTable - , updatee :: !Closure + , updatee :: !b } | CatchFrame { info_tbl :: !StgInfoTable - , exceptions_blocked :: Word - , handler :: !Closure + , exceptions_blocked :: !Word + , handler :: !b } | CatchStmFrame { info_tbl :: !StgInfoTable - , catchFrameCode :: !Closure - , handler :: !Closure + , catchFrameCode :: !b + , handler :: !b } | CatchRetryFrame { info_tbl :: !StgInfoTable , running_alt_code :: !Word - , first_code :: !Closure - , alt_code :: !Closure + , first_code :: !b + , alt_code :: !b } | AtomicallyFrame { info_tbl :: !StgInfoTable - , atomicallyFrameCode :: !Closure - , result :: !Closure + , atomicallyFrameCode :: !b + , result :: !b } | UnderflowFrame { info_tbl :: !StgInfoTable - , nextChunk :: !StgStackClosure + , nextChunk :: !(GenStgStackClosure b) } | StopFrame @@ -429,26 +442,26 @@ data StackFrame = | RetSmall { info_tbl :: !StgInfoTable - , stack_payload :: ![Closure] + , stack_payload :: ![GenStackField b] } | RetBig { info_tbl :: !StgInfoTable - , stack_payload :: ![Closure] + , stack_payload :: ![GenStackField b] } | RetFun { info_tbl :: !StgInfoTable - , retFunType :: RetFunType - , retFunSize :: Word - , retFunFun :: !Closure - , retFunPayload :: ![Closure] + , retFunType :: !RetFunType + , retFunSize :: !Word + , retFunFun :: !b + , retFunPayload :: ![GenStackField b] } | RetBCO { info_tbl :: !StgInfoTable - , bco :: !Closure -- must be a BCOClosure - , bcoArgs :: ![Closure] + , bco :: !b -- is always a BCOClosure + , bcoArgs :: ![GenStackField b] } deriving (Show, Generic) ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -23,14 +23,16 @@ import Data.Bits import Data.Maybe import Foreign import GHC.Exts -import GHC.Exts.Heap (Box (..), getBoxedClosureData) +import GHC.Exts.Heap (Box (..)) import GHC.Exts.Heap.ClosureTypes import GHC.Exts.Heap.Closures - ( Closure, - GenClosure (UnknownTypeWordSizedPrimitive), - RetFunType (..), - StackFrame (..), - StgStackClosure (..), + ( RetFunType (..), + StackFrame, + GenStackFrame (..), + StgStackClosure, + GenStgStackClosure (..), + StackField, + GenStackField(..) ) import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS) import GHC.Exts.Heap.InfoTable @@ -211,20 +213,18 @@ advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) = primWordToWordOffset :: Word# -> WordOffset primWordToWordOffset w# = fromIntegral (W# w#) -getClosure :: StackSnapshot# -> WordOffset -> IO Closure -getClosure stackSnapshot# index = +getClosureBox :: StackSnapshot# -> WordOffset -> IO Box +getClosureBox stackSnapshot# index = -- Beware! We have to put ptr into a Box immediately. Otherwise, the garbage -- collector might move the referenced closure, without updating our reference -- (pointer) to it. - ( IO $ \s -> + IO $ \s -> case getStackClosure# stackSnapshot# (wordOffsetToWord# index) s of (# s1, ptr #) -> (# s1, Box ptr #) - ) - >>= getBoxedClosureData -- | Representation of @StgLargeBitmap@ (RTS) data LargeBitmap = LargeBitmap @@ -236,7 +236,7 @@ data LargeBitmap = LargeBitmap data Pointerness = Pointer | NonPointer deriving (Show) -decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure] +decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField] decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#) @@ -276,17 +276,17 @@ bitmapWordPointerness bSize bitmapWord = (bSize - 1) (bitmapWord `shiftR` 1) -decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> IO [Closure] +decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> IO [StackField] decodeBitmaps stack# index ps = zipWithM toPayload ps [index ..] where - toPayload :: Pointerness -> WordOffset -> IO Closure + toPayload :: Pointerness -> WordOffset -> IO StackField toPayload p i = case p of NonPointer -> - pure $ UnknownTypeWordSizedPrimitive (getWord stack# i) - Pointer -> getClosure stack# i + pure $ StackWord (getWord stack# i) + Pointer -> StackBox <$> getClosureBox stack# i -decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure] +decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField] decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of (# b#, s# #) -> (W# b#, W# s#) @@ -304,7 +304,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do unpackStackFrame' info = case tipe info of RET_BCO -> do - bco' <- getClosure stackSnapshot# (index + offsetStgClosurePayload) + bco' <- getClosureBox stackSnapshot# (index + offsetStgClosurePayload) -- The arguments begin directly after the payload's one element bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) pure @@ -330,7 +330,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do RET_FUN -> do let retFunType' = getRetFunType stackSnapshot# index retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize) - retFunFun' <- getClosure stackSnapshot# (index + offsetStgRetFunFrameFun) + retFunFun' <- getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun) retFunPayload' <- if retFunType' == ARG_GEN_BIG then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload @@ -344,7 +344,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do retFunPayload = retFunPayload' } UPDATE_FRAME -> do - updatee' <- getClosure stackSnapshot# (index + offsetStgUpdateFrameUpdatee) + updatee' <- getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) pure $ UpdateFrame { info_tbl = info, @@ -352,7 +352,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do } CATCH_FRAME -> do let exceptions_blocked' = getWord stackSnapshot# (index + offsetStgCatchFrameExceptionsBlocked) - handler' <- getClosure stackSnapshot# (index + offsetStgCatchFrameHandler) + handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) pure $ CatchFrame { info_tbl = info, @@ -369,8 +369,8 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do } STOP_FRAME -> pure $ StopFrame {info_tbl = info} ATOMICALLY_FRAME -> do - atomicallyFrameCode' <- getClosure stackSnapshot# (index + offsetStgAtomicallyFrameCode) - result' <- getClosure stackSnapshot# (index + offsetStgAtomicallyFrameResult) + atomicallyFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) + result' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) pure $ AtomicallyFrame { info_tbl = info, @@ -379,8 +379,8 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do } CATCH_RETRY_FRAME -> do let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode) - first_code' <- getClosure stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) - alt_code' <- getClosure stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) + first_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) + alt_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) pure $ CatchRetryFrame { info_tbl = info, @@ -389,8 +389,8 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do alt_code = alt_code' } CATCH_STM_FRAME -> do - catchFrameCode' <- getClosure stackSnapshot# (index + offsetStgCatchSTMFrameCode) - handler' <- getClosure stackSnapshot# (index + offsetStgCatchSTMFrameHandler) + catchFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) + handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) pure $ CatchStmFrame { info_tbl = info, @@ -430,7 +430,7 @@ decodeStack (StackSnapshot stack#) = do sfls = stackFrameLocations stack# stack' <- mapM unpackStackFrame sfls pure $ - StgStackClosure + GenStgStackClosure { ssc_info = info, ssc_stack_size = stack_size', ssc_stack_dirty = stack_dirty', View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc135403e75c95c697d48afc7b085ae757560ca5...03425236b30f2e9bb3ceef58a0e31cc048137da5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc135403e75c95c697d48afc7b085ae757560ca5...03425236b30f2e9bb3ceef58a0e31cc048137da5 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 18:58:32 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 14:58:32 -0400 Subject: [Git][ghc/ghc][master] 5 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <64540058b33fc_e3e0651f042622b5@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 12 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile - hadrian/bootstrap/plan-9_2_1.json - hadrian/bootstrap/plan-9_2_2.json - hadrian/bootstrap/plan-9_2_3.json The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8fde4ac84ec7b1ead238cb158bbef48555d12af9...944a9b94ceea429f05f336a035088b1ebd26ddc4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8fde4ac84ec7b1ead238cb158bbef48555d12af9...944a9b94ceea429f05f336a035088b1ebd26ddc4 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 18:59:26 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 14:59:26 -0400 Subject: [Git][ghc/ghc][master] 2 commits: JS: fix bounds checking (Issue 23123) Message-ID: <6454008eb8bda_e3e063c09fc42660c1@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 10 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -138,6 +138,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,218 +526,206 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayNonOverlappingOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToAddrNonOverlappingOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -756,107 +743,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -917,17 +855,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1031,184 +969,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1367,6 +1203,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1391,6 +1300,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1406,6 +1327,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1416,6 +1347,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1431,8 +1374,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1444,39 +1387,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== libraries/base/jsbits/base.js ===================================== @@ -878,8 +878,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,4 +229,4 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/944a9b94ceea429f05f336a035088b1ebd26ddc4...2d5c1ddecf195da9a8ee4f7b38fbb79d3b680aeb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/944a9b94ceea429f05f336a035088b1ebd26ddc4...2d5c1ddecf195da9a8ee4f7b38fbb79d3b680aeb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 18:59:48 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 14:59:48 -0400 Subject: [Git][ghc/ghc][master] JavaScript: Correct arguments to h$appendToHsStringA Message-ID: <645400a4e1ed3_e3e0616e4651827114a@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - 1 changed file: - compiler/GHC/StgToJS/Apply.hs Changes: ===================================== compiler/GHC/StgToJS/Apply.hs ===================================== @@ -110,7 +110,7 @@ genApp ctx i args prof <- csProf <$> getSettings let profArg = if prof then [jCafCCS] else [] a <- genArg x - return ( top |= app "h$appendToHsStringA" ([toJExpr d, toJExpr a] ++ profArg) + return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg) , ExprInline Nothing ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98c5ee4526d1830beff4203062eb1c8e903db9bb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98c5ee4526d1830beff4203062eb1c8e903db9bb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 19:00:25 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 15:00:25 -0400 Subject: [Git][ghc/ghc][master] base/encoding: add an allocations performance test (#22946) Message-ID: <645400c911c0b_e3e0613e02d98274544@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - 2 changed files: - libraries/base/tests/perf/all.T - + libraries/base/tests/perf/encodingAllocations.hs Changes: ===================================== libraries/base/tests/perf/all.T ===================================== @@ -1,5 +1,14 @@ +# .stats files aren't yet supported in the JS backend +setTestOpts(js_skip) + #-------------------------------------- # Check specialization of elem via rules #-------------------------------------- test('T17752', [only_ways(['normal'])] , makefile_test, ['T17752']) + +#-------------------------------------- + +# We don't expect the code in test to vary at all, but the variance is set to +# 1% in case the constant allocations increase by other means. +test('encodingAllocations', [only_ways(['normal']), collect_stats('bytes allocated', 1)], compile_and_run, ['-O2']) ===================================== libraries/base/tests/perf/encodingAllocations.hs ===================================== @@ -0,0 +1,30 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -dno-typeable-binds -O2 #-} + +module Main (main) where + +import System.IO +import Data.Bits +import GHC.Int +import GHC.Exts +import System.Environment +import Distribution.Simple.Utils + + +main :: IO () +main = withTempFile "." "encodingAllocations.tmp" (const $ loop 1000000) + +loop :: Int -> Handle -> IO () +loop 0 !_ = pure () +loop !n !h = do + hPutChar h $! dummy_char n + loop (n-1) h + +-- unsafe efficient version of `chr` +my_chr :: Int -> Char +my_chr (I# i) = C# (chr# i) + +-- return either a or b +dummy_char :: Int -> Char +dummy_char !i = my_chr ((i .&. 1) + 97) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca611447986fab9da82f4272f90fae3f0afda5a7 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca611447986fab9da82f4272f90fae3f0afda5a7 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 19:01:02 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 15:01:02 -0400 Subject: [Git][ghc/ghc][master] linear types: Don't add external names to the usage env Message-ID: <645400eeaa1d8_e3e063c09fc42780b8@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - 3 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Tc/Gen/Head.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -3210,7 +3210,7 @@ varCallSiteUsage :: Id -> LintM UsageEnv varCallSiteUsage id = do m <- getUEAliases return $ case lookupNameEnv m (getName id) of - Nothing -> unitUE id OneTy + Nothing -> singleUsageUE id Just id_ue -> id_ue ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM () ===================================== compiler/GHC/Core/UsageEnv.hs ===================================== @@ -10,13 +10,14 @@ module GHC.Core.UsageEnv , scaleUsage , supUE , supUEs - , unitUE + , singleUsageUE , zeroUE ) where import Data.Foldable import GHC.Prelude import GHC.Core.Multiplicity +import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable @@ -54,8 +55,13 @@ scaleUsage x (MUsage y) = MUsage $ mkMultMul x y -- For now, we use extra multiplicity Bottom for empty case. data UsageEnv = UsageEnv !(NameEnv Mult) Bool -unitUE :: NamedThing n => n -> Mult -> UsageEnv -unitUE x w = UsageEnv (unitNameEnv (getName x) w) False +-- | Record a single usage of an Id, i.e. {n: 1} +-- Exception: We do not record external names (both GlobalIds and top-level LocalIds) +-- because they're not relevant to linearity checking. +singleUsageUE :: Id -> UsageEnv +singleUsageUE x | isExternalName n = zeroUE + | otherwise = UsageEnv (unitNameEnv n OneTy) False + where n = getName x zeroUE, bottomUE :: UsageEnv zeroUE = UsageEnv emptyNameEnv False ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -48,7 +48,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Core.UsageEnv ( unitUE ) +import GHC.Core.UsageEnv ( singleUsageUE ) import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env @@ -1091,7 +1091,7 @@ tc_infer_id id_name check_local_id :: Id -> TcM () check_local_id id = do { checkThLocalId id - ; tcEmitBindingUsage $ unitUE (idName id) OneTy } + ; tcEmitBindingUsage $ singleUsageUE id } check_naughty :: OccName -> TcId -> TcM () check_naughty lbl id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3ddf58d26cb490e5bf523d45b37c4d95379f19c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3ddf58d26cb490e5bf523d45b37c4d95379f19c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 19:01:44 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 15:01:44 -0400 Subject: [Git][ghc/ghc][master] Improved documentation for the Data.OldList.nub function Message-ID: <645401184b8ac_e3e063a20fc82816e4@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - 1 changed file: - libraries/base/Data/OldList.hs Changes: ===================================== libraries/base/Data/OldList.hs ===================================== @@ -448,10 +448,16 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- >>> nub [1,2,3,4,3,2,1,2,4,3,5] -- [1,2,3,4,5] -- --- If the order of outputs does not matter and there exists @instance Ord a@, --- it's faster to use +-- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package +-- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Containers-ListUtils.html#v:nubOrd)), +-- which takes only \(\mathcal{O}(n \log d)\) time where `d` is the number of +-- distinct elements in the list. +-- +-- Another approach to speed up 'nub' is to use -- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes only \(\mathcal{O}(n \log n)\) time. +-- which takes \(\mathcal{O}(n \log n)\) time, requires @instance Ord a@ and doesn't +-- preserve the order. + -- nub :: (Eq a) => [a] -> [a] nub = nubBy (==) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3226616beaa8cd4d3289b8a9d4bb0a9b8936f8e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3226616beaa8cd4d3289b8a9d4bb0a9b8936f8e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu May 4 19:02:25 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 May 2023 15:02:25 -0400 Subject: [Git][ghc/ghc][master] Fix type variable substitution in gen_Newtype_fam_insts Message-ID: <64540141934cc_e3e06192c28882868d8@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 5 changed files: - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/TyCl/Class.hs - + testsuite/tests/deriving/should_compile/T23329.hs - + testsuite/tests/deriving/should_compile/T23329_M.hs - testsuite/tests/deriving/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -46,6 +46,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate( newFamInst ) import GHC.Tc.Utils.Env @@ -2100,8 +2101,8 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty newFamInst SynFamilyInst axiom where fam_tvs = tyConTyVars fam_tc - rep_lhs_tys = substTyVars lhs_subst fam_tvs - rep_rhs_tys = substTyVars rhs_subst fam_tvs + (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs + (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -22,6 +22,7 @@ module GHC.Tc.TyCl.Class , instDeclCtxt2 , instDeclCtxt3 , tcATDefault + , substATBndrs ) where @@ -42,7 +43,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad import GHC.Tc.TyCl.Build( TcMethInfo ) -import GHC.Core.Type ( piResultTys ) +import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Core.Class @@ -58,7 +59,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var -import GHC.Types.Var.Env +import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) import GHC.Types.SrcLoc import GHC.Types.Basic @@ -501,8 +502,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) -- instance C [x] -- Then we want to generate the decl: type F [x] b = () | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst - (tyConTyVars fam_tc) + = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc) rhs' = substTyUnchecked subst' rhs_ty tcv' = tyCoVarsOfTypesList pat_tys' (tv', cv') = partition isTyVar tcv' @@ -525,14 +525,73 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) | otherwise -- defs = Nothing = do { warnMissingAT (tyConName fam_tc) ; return [] } + +-- | Apply a substitution to the type variable binders of an associated type +-- family. This is used to compute default instances for associated type +-- families (see 'tcATDefault') as well as @newtype at -derived associated type +-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate"). +-- +-- As a concrete example, consider the following class and associated type +-- family: +-- +-- @ +-- class C k (a :: k) where +-- type F k a (b :: k) :: Type +-- type F j p q = (Proxy @j p, Proxy @j (q :: j)) +-- @ +-- +-- If a user defines this instance: +-- +-- @ +-- instance C (Type -> Type) Maybe where {} +-- @ +-- +-- Then in order to typecheck the default @F@ instance, we must apply the +-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which +-- are @[k, a, (b :: k)]@. The result should look like this: +-- +-- @ +-- type F (Type -> Type) Maybe (b :: Type -> Type) = +-- (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type)) +-- @ +-- +-- Making this work requires some care. There are two cases: +-- +-- 1. If we encounter a type variable in the domain of the substitution (e.g., +-- @k@ or @a@), then we apply the substitution directly. +-- +-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn +-- @b :: k@ to @b :: Type -> Type@). We then return an extended substitution +-- where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@). +-- +-- This step is important to do in case there are later occurrences of @b@, +-- which we must ensure have the correct kind. Otherwise, we might end up +-- with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the +-- default instance, which would be completely wrong. +-- +-- Contrast 'substATBndrs' function with similar substitution functions: +-- +-- * 'substTyVars' does not substitute into the kinds of each type variable, +-- nor does it extend the substitution. 'substTyVars' is meant for occurrences +-- of type variables, whereas 'substATBndr's is meant for binders. +-- +-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution, +-- but it does not apply the substitution to the variables themselves. As +-- such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of +-- 'Type's. +substATBndrs :: Subst -> [TyVar] -> (Subst, [Type]) +substATBndrs = mapAccumL substATBndr where - subst_tv subst tc_tv + substATBndr :: Subst -> TyVar -> (Subst, Type) + substATBndr subst tc_tv + -- Case (1) in the Haddocks | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty) + -- Case (2) in the Haddocks | otherwise - = (extendTvSubst subst tc_tv ty', ty') + = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv') where - ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) + tc_tv' = updateTyVarKind (substTy subst) tc_tv warnMissingAT :: Name -> TcM () warnMissingAT name ===================================== testsuite/tests/deriving/should_compile/T23329.hs ===================================== @@ -0,0 +1,9 @@ +module T23329 where + +import Data.Kind (Type) +import Data.Proxy (Proxy(Proxy)) + +import T23329_M + +foo :: () +foo = myMethod @Type @MyMaybe @() () Proxy Proxy ===================================== testsuite/tests/deriving/should_compile/T23329_M.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module T23329_M where + +import Data.Kind (Type) +import Data.Proxy (Proxy) + +class MyClass (f :: k -> Type) where + type MyTypeFamily f (i :: k) :: Type + myMethod :: MyTypeFamily f i -> Proxy f -> Proxy i -> () + +instance MyClass Maybe where + type MyTypeFamily Maybe i = () + myMethod = undefined + +newtype MyMaybe a = MyMaybe (Maybe a) + deriving MyClass ===================================== testsuite/tests/deriving/should_compile/all.T ===================================== @@ -141,3 +141,4 @@ test('T20994', normal, compile, ['']) test('T22167', normal, compile, ['']) test('T22696a', normal, compile, ['']) test('T22696c', normal, compile, ['']) +test('T23329', normal, multimod_compile, ['T23329', '-v0']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8b72ff6e4aee1f889a9168df57bb1b00168fd21 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8b72ff6e4aee1f889a9168df57bb1b00168fd21 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 07:45:00 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 05 May 2023 03:45:00 -0400 Subject: [Git][ghc/ghc][wip/T23083] 3 commits: CorePrep: Eliminate EmptyCase and unsafeEqualityProof in CoreToStg instead Message-ID: <6454b3fc10f95_e3e06193e5e0431104a@gitlab.mail> Sebastian Graf pushed to branch wip/T23083 at Glasgow Haskell Compiler / GHC Commits: 8b637a51 by Sebastian Graf at 2023-05-05T09:44:48+02:00 CorePrep: Eliminate EmptyCase and unsafeEqualityProof in CoreToStg instead We eliminate EmptyCase by way of `coreToStg (Case e _ _ []) = coreToStg e` now. The main reason is that it plays far better in conjunction with eta expansion (as we aim to do for arguments in CorePrep, #23083), because we can discard any arguments, `(case e of {}) eta == case e of {}`, whereas in `(e |> co) eta` it's impossible to discard the argument. We do also give the same treatment to unsafeCoerce proofs and treat them as trivial iff their RHS is trivial. It is also both much simpler to describe than the previous mechanism of emitting an unsafe coercion and simpler to implement, removing quite a bit of commentary and `CorePrepProv`. - - - - - 32cc009e by Sebastian Graf at 2023-05-05T09:44:48+02:00 CorePrep: Eta expand arguments (#23083) Previously, we'd only eta expand let bindings and lambdas, now we'll also eta expand arguments such as in T23083: ```hs g f h = f (h `seq` (h $)) ``` Unless `-fpedantic-bottoms` is set, we'll now transform to ```hs g f h = f (\eta -> h eta) ``` in CorePrep. See the new `Note [Eta expansion of arguments in CorePrep]` for the details. We only do this optimisation with -O2 because we saw 2-3% ghc/alloc regressions in T4801 and T5321FD. Fixes #23083. - - - - - f9ebee2c by Sebastian Graf at 2023-05-05T09:44:48+02:00 Deactivate -fcatch-nonexhaustive-cases in ghc-bignum (#23345) - - - - - 30 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCo/Tidy.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/CoreToStg/Prep.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Utils/Trace.hs - docs/users_guide/using-optimisation.rst - libraries/base/Unsafe/Coerce.hs - libraries/ghc-bignum/ghc-bignum.cabal - libraries/ghc-bignum/src/GHC/Num/BigNat.hs - + testsuite/tests/simplCore/should_compile/T23083.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd286b5029a42ddb70bb4ae21d000fd03889fd49...f9ebee2ce4c512730ca4782393936afb6d2e52fd -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd286b5029a42ddb70bb4ae21d000fd03889fd49...f9ebee2ce4c512730ca4782393936afb6d2e52fd You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 08:43:53 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 05 May 2023 04:43:53 -0400 Subject: [Git][ghc/ghc][wip/plugin-init] 155 commits: Make exprIsConApp_maybe a bit cleverer Message-ID: <6454c1c9a4a87_e3e0616e4b0a4315379@gitlab.mail> Matthew Pickering pushed to branch wip/plugin-init at Glasgow Haskell Compiler / GHC Commits: c1f755c4 by Simon Peyton Jones at 2023-03-27T22:09:41+01:00 Make exprIsConApp_maybe a bit cleverer Addresses #23159. See Note Note [Exploit occ-info in exprIsConApp_maybe] in GHC.Core.SimpleOpt. Compile times go down very slightly, but always go down, never up. Good! Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -1.8% T15703(normal) -1.2% GOOD geo. mean -0.1% minimum -1.8% maximum +0.0% Metric Decrease: CoOpt_Singletons T15703 - - - - - 76bb4c58 by Ryan Scott at 2023-03-28T08:12:08-04:00 Add COMPLETE pragmas to TypeRep, SSymbol, SChar, and SNat This implements [CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149). - - - - - 3f374399 by sheaf at 2023-03-29T13:57:33+02:00 Handle records in the renamer This patch moves the field-based logic for disambiguating record updates to the renamer. The type-directed logic, scheduled for removal, remains in the typechecker. To do this properly (and fix the myriad of bugs surrounding the treatment of duplicate record fields), we took the following main steps: 1. Create GREInfo, a renamer-level equivalent to TyThing which stores information pertinent to the renamer. This allows us to uniformly treat imported and local Names in the renamer, as described in Note [GREInfo]. 2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which distinguished between normal names and field names, we now store simple Names in GlobalRdrElt, along with the new GREInfo information which allows us to recover the FieldLabel for record fields. 3. Add namespacing for record fields, within the OccNames themselves. This allows us to remove the mangling of duplicate field selectors. This change ensures we don't print mangled names to the user in error messages, and allows us to handle duplicate record fields in Template Haskell. 4. Move record disambiguation to the renamer, and operate on the level of data constructors instead, to handle #21443. The error message text for ambiguous record updates has also been changed to reflect that type-directed disambiguation is on the way out. (3) means that OccEnv is now a bit more complex: we first key on the textual name, which gives an inner map keyed on NameSpace: OccEnv a ~ FastStringEnv (UniqFM NameSpace a) Note that this change, along with (2), both increase the memory residency of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to regress somewhat in compile-time allocation. Even though (3) simplified a lot of code (in particular the treatment of field selectors within Template Haskell and in error messages), it came with one important wrinkle: in the situation of -- M.hs-boot module M where { data A; foo :: A -> Int } -- M.hs module M where { data A = MkA { foo :: Int } } we have that M.hs-boot exports a variable foo, which is supposed to match with the record field foo that M exports. To solve this issue, we add a new impedance-matching binding to M foo{var} = foo{fld} This mimics the logic that existed already for impedance-binding DFunIds, but getting it right was a bit tricky. See Note [Record field impedance matching] in GHC.Tc.Module. We also needed to be careful to avoid introducing space leaks in GHCi. So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in ModIface. This means stubbing out all the GREInfo fields, with the function forceGlobalRdrEnv. When we read it back in, we rehydrate with rehydrateGlobalRdrEnv. This robustly avoids any space leaks caused by retaining old type environments. Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063 Updates haddock submodule ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiLayerModulesDefsGhci MultiLayerModulesNoCode T13701 T14697 hard_hole_fits ------------------------- - - - - - 4f1940f0 by sheaf at 2023-03-29T13:57:33+02:00 Avoid repeatedly shadowing in shadowNames This commit refactors GHC.Type.Name.Reader.shadowNames to first accumulate all the shadowing arising from the introduction of a new set of GREs, and then applies all the shadowing to the old GlobalRdrEnv in one go. - - - - - d246049c by sheaf at 2023-03-29T13:57:34+02:00 igre_prompt_env: discard "only-qualified" names We were unnecessarily carrying around names only available qualified in igre_prompt_env, violating the icReaderEnv invariant. We now get rid of these, as they aren't needed for the shadowing computation that igre_prompt_env exists for. Fixes #23177 ------------------------- Metric Decrease: T14052 T14052Type ------------------------- - - - - - 41a572f6 by Matthew Pickering at 2023-03-29T16:17:21-04:00 hadrian: Fix path to HpcParser.y The source for this project has been moved into a src/ folder so we also need to update this path. Fixes #23187 - - - - - b159e0e9 by doyougnu at 2023-03-30T01:40:08-04:00 js: split JMacro into JS eDSL and JS syntax This commit: Splits JExpr and JStat into two nearly identical DSLs: - GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a value cannot be unsaturated, or, a value of this DSL is a witness that a value of GHC.JS.Unsat has been saturated - GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation. Then all binary and outputable instances are changed to use GHC.JS.Syntax. This moves us closer to closing out #22736 and #22352. See #22736 for roadmap. ------------------------- Metric Increase: CoOpt_Read LargeRecord ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T10858 T11195 T11374 T11822 T12227 T12707 T13035 T13253 T13253-spj T13379 T14683 T15164 T15703 T16577 T17096 T17516 T17836 T18140 T18282 T18304 T18478 T18698a T18698b T18923 T1969 T19695 T20049 T21839c T3064 T4801 T5321FD T5321Fun T5631 T5642 T783 T9198 T9233 T9630 TcPlugin_RewritePerf WWRec ------------------------- - - - - - f4f1f14f by Sylvain Henry at 2023-03-30T01:40:49-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. Also used the opportunity to reenable 64-bit Word/Int tests - - - - - a5360490 by Ben Gamari at 2023-03-30T01:41:25-04:00 testsuite: Fix racing prints in T21465 As noted in #23155, we previously failed to add flushes necessary to ensure predictable output. Fixes #23155. - - - - - 98b5cf67 by Matthew Pickering at 2023-03-30T09:58:40+01:00 Revert "ghc-heap: remove wrong Addr# coercion (#23181)" This reverts commit f4f1f14f8009c3c120b8b963ec130cbbc774ec02. This fails to build with GHC-9.2 as a boot compiler. See #23195 for tracking this issue. - - - - - 61a2dfaa by Bodigrim at 2023-03-30T14:35:57-04:00 Add {-# WARNING #-} to Data.List.{head,tail} - - - - - 8f15c47c by Bodigrim at 2023-03-30T14:35:57-04:00 Fixes to accomodate Data.List.{head,tail} with {-# WARNING #-} - - - - - 7c7dbade by Bodigrim at 2023-03-30T14:35:57-04:00 Bump submodules - - - - - d2d8251b by Bodigrim at 2023-03-30T14:35:57-04:00 Fix tests - - - - - 3d38dcb6 by sheaf at 2023-03-30T14:35:57-04:00 Proxies for head and tail: review suggestions - - - - - 930edcfd by sheaf at 2023-03-30T14:36:33-04:00 docs: move RecordUpd changelog entry to 9.8 This was accidentally included in the 9.6 changelog instead of the 9.6 changelog. - - - - - 6f885e65 by sheaf at 2023-03-30T14:37:09-04:00 Add LANGUAGE GADTs to GHC.Rename.Env We need to enable this extension for the file to compile with ghc 9.2, as we are pattern matching on a GADT and this required the GADT extension to be enabled until 9.4. - - - - - 6d6a37a8 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: make lint-ci-config job fast again We don't pin our nixpkgs revision and tracks the default nixpkgs-unstable channel anyway. Instead of using haskell.packages.ghc924, we should be using haskell.packages.ghc92 to maximize the binary cache hit rate and make lint-ci-config job fast again. Also bumps the nix docker image to the latest revision. - - - - - ef1548c4 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: ensure that all non-i386 pipelines do parallel xz compression We can safely enable parallel xz compression for non-i386 pipelines. However, previously we didn't export XZ_OPT, so the xz process won't see it if XZ_OPT hasn't already been set in the current job. - - - - - 20432d16 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: unset CROSS_EMULATOR for js job - - - - - 4a24dbbe by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: fix lint-testsuite job The list_broken make target will transitively depend on the calibrate.out target, which used STAGE1_GHC instead of TEST_HC. It really should be TEST_HC since that's what get passed in the gitlab CI config. - - - - - cea56ccc by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: use alpine3_17-wasm image for wasm jobs Bump the ci-images dependency and use the new alpine3_17-wasm docker image for wasm jobs. - - - - - 79d0cb32 by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - e7392b4e by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Normalize away differences in ghc executable name - - - - - ee160d06 by Ben Gamari at 2023-03-30T18:43:53+00:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - 30c84511 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: don't add optllvm way for wasm32 - - - - - f1beee36 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: normalize the .wasm extension - - - - - a984a103 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: strip the cross ghc prefix in output and error message - - - - - f7478d95 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: handle target executable extension - - - - - 8fe8b653 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: mypy typing error fixes This patch fixes some mypy typing errors which weren't caught in previous linting jobs. - - - - - 0149f32f by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: use context variable instead of thread-local variable This patch changes a thread-local variable to context variable instead, which works as intended when the testsuite transitions to use asyncio & coroutines instead of multi-threading to concurrently run test cases. Note that this also raises the minimum Python version to 3.7. - - - - - ea853ff0 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: asyncify the testsuite driver This patch refactors the testsuite driver, gets rid of multi-threading logic for running test cases concurrently, and uses asyncio & coroutines instead. This is not yak shaving for its own sake; the previous multi-threading logic is prone to livelock/deadlock conditions for some reason, even if the total number of threads is bounded to a thread pool's capacity. The asyncify change is an internal implementation detail of the testsuite driver and does not impact most GHC maintainers out there. The patch does not touch the .T files, test cases can be added/modified the exact same way as before. - - - - - 0077cb22 by Matthew Pickering at 2023-03-31T21:28:28-04:00 Add test for T23184 There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj at microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 A bunch of changes related to eta reduction This is a large collection of changes all relating to eta reduction, originally triggered by #18993, but there followed a long saga. Specifics: ...lots of lines omitted... Other incidental changes * Fix a fairly long-standing outright bug in the ApplyToVal case of GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the tail of 'dmds' in the recursive call, which meant the demands were All Wrong. I have no idea why this has not caused problems before now. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes. - - - - - 62d25071 by mangoiv at 2023-04-01T04:20:01-04:00 [feat] make ($) representation polymorphic - this change was approved by the CLC in [1] following a CLC proposal [2] - make ($) representation polymorphic (adjust the type signature) - change ($) implementation to allow additional polymorphism - adjust the haddock of ($) to reflect these changes - add additional documentation to document these changes - add changelog entry - adjust tests (move now succeeding tests and adjust stdout of some tests) [1] https://github.com/haskell/core-libraries-committee/issues/132#issuecomment-1487456854 [2] https://github.com/haskell/core-libraries-committee/issues/132 - - - - - 77c33fb9 by Artem Pelenitsyn at 2023-04-01T04:20:41-04:00 User Guide: update copyright year: 2020->2023 - - - - - 3b5be05a by doyougnu at 2023-04-01T09:42:31-04:00 driver: Unit State Data.Map -> GHC.Unique.UniqMap In pursuit of #22426. The driver and unit state are major contributors. This commit also bumps the haddock submodule to reflect the API changes in UniqMap. ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp T10421 T10547 T12150 T12234 T12425 T13035 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T5837 T6048 T9198 ------------------------- - - - - - a84fba6e by Torsten Schmits at 2023-04-01T09:43:12-04:00 Add structured error messages for GHC.Tc.TyCl Tracking ticket: #20117 MR: !10183 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 6e2eb275 by doyougnu at 2023-04-01T18:27:56-04:00 JS: Linker: use saturated JExpr Follow on to MR!10142 in pursuit of #22736 - - - - - 3da69346 by sheaf at 2023-04-01T18:28:37-04:00 Improve haddocks of template-haskell Con datatype This adds a bit more information, in particular about the lists of constructors in the GadtC and RecGadtC cases. - - - - - 3b7bbb39 by sheaf at 2023-04-01T18:28:37-04:00 TH: revert changes to GadtC & RecGadtC Commit 3f374399 included a breaking-change to the template-haskell library when it made the GadtC and RecGadtC constructors take non-empty lists of names. As this has the potential to break many users' packages, we decided to revert these changes for now. - - - - - f60f6110 by Bodigrim at 2023-04-02T18:59:30-04:00 Rework documentation for data Char - - - - - 43ebd5dc by Bodigrim at 2023-04-02T19:00:09-04:00 cmm: implement parsing of MO_AtomicRMW from hand-written CMM files Fixes #23206 - - - - - ab9cd52d by Sylvain Henry at 2023-04-03T08:15:21-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. - - - - - 2b2afff3 by Matthew Pickering at 2023-04-03T08:15:58-04:00 hadrian: Update bootstrap plans for 9.2.6, 9.2.7, 9.4.4, 9.4.5, 9.6.1 Also fixes the ./generate_bootstrap_plans script which was recently broken We can hopefully drop the 9.2 plans soon but they still work so kept them around for now. - - - - - c2605e25 by Matthew Pickering at 2023-04-03T08:15:58-04:00 ci: Add job to test 9.6 bootstrapping - - - - - 53e4d513 by Krzysztof Gogolewski at 2023-04-03T08:16:35-04:00 hadrian: Improve option parsing Several options in Hadrian had their argument marked as optional (`OptArg`), but if the argument wasn't there they were just giving an error. It's more idiomatic to mark the argument as required instead; the code uses less Maybes, the parser can enforce that the argument is present, --help gives better output. - - - - - a8e36892 by Sylvain Henry at 2023-04-03T08:17:16-04:00 JS: fix issues with FD api support - Add missing implementations for fcntl_read/write/lock - Fix fdGetMode These were found while implementing TH in !9779. These functions must be used somehow by the external interpreter code. - - - - - 8b092910 by Haskell-mouse at 2023-04-03T19:31:26-04:00 Convert diagnostics in GHC.Rename.HsType to proper TcRnMessage I've turned all occurrences of TcRnUnknownMessage in GHC.Rename.HsType module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnDataKindsError TcRnUnusedQuantifiedTypeVar TcRnIllegalKindSignature TcRnUnexpectedPatSigType TcRnSectionPrecedenceError TcRnPrecedenceParsingError TcRnIllegalKind TcRnNegativeNumTypeLiteral TcRnUnexpectedKindVar TcRnBindMultipleVariables TcRnBindVarAlreadyInScope - - - - - 220a7a48 by Krzysztof Gogolewski at 2023-04-03T19:32:02-04:00 Fixes around unsafeCoerce# 1. `unsafeCoerce#` was documented in `GHC.Prim`. But since the overhaul in 74ad75e87317, `unsafeCoerce#` is no longer defined there. I've combined the documentation in `GHC.Prim` with the `Unsafe.Coerce` module. 2. The documentation of `unsafeCoerce#` stated that you should not cast a function to an algebraic type, even if you later cast it back before applying it. But ghci was doing that type of cast, as can be seen with 'ghci -ddump-ds' and typing 'x = not'. I've changed it to use Any following the documentation. - - - - - 9095e297 by Matthew Craven at 2023-04-04T01:04:10-04:00 Add a few more memcpy-ish primops * copyMutableByteArrayNonOverlapping# * copyAddrToAddr# * copyAddrToAddrNonOverlapping# * setAddrRange# The implementations of copyBytes, moveBytes, and fillBytes in base:Foreign.Marshal.Utils now use these new primops, which can cause us to work a bit harder generating code for them, resulting in the metric increase in T21839c observed by CI on some architectures. But in exchange, we get better code! Metric Increase: T21839c - - - - - f7da530c by Matthew Craven at 2023-04-04T01:04:10-04:00 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. - - - - - cd00e321 by sheaf at 2023-04-04T01:04:50-04:00 Relax assertion in varToRecFieldOcc When using Template Haskell, it is possible to re-parent a field OccName belonging to one data constructor to another data constructor. The lsp-types package did this in order to "extend" a data constructor with additional fields. This ran into an assertion in 'varToRecFieldOcc'. This assertion can simply be relaxed, as the resulting splices are perfectly sound. Fixes #23220 - - - - - eed0d930 by Sylvain Henry at 2023-04-04T11:09:15-04:00 GHCi.RemoteTypes: fix doc and avoid unsafeCoerce (#23201) - - - - - 071139c3 by Ryan Scott at 2023-04-04T11:09:51-04:00 Make INLINE pragmas for pattern synonyms work with TH Previously, the code for converting `INLINE <name>` pragmas from TH splices used `vNameN`, which assumed that `<name>` must live in the variable namespace. Pattern synonyms, on the other hand, live in the constructor namespace. I've fixed the issue by switching to `vcNameN` instead, which works for both the variable and constructor namespaces. Fixes #23203. - - - - - 7c16f3be by Krzysztof Gogolewski at 2023-04-04T17:13:00-04:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). - - - - - c165f079 by sheaf at 2023-04-04T17:13:40-04:00 Add testcase for #23192 This issue around solving of constraints arising from superclass expansion using other constraints also borned from superclass expansion was the topic of commit aed1974e. That commit made sure we don't emit a "redundant constraint" warning in a situation in which removing the constraint would cause errors. Fixes #23192 - - - - - d1bb16ed by Ben Gamari at 2023-04-06T03:40:45-04:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 - - - - - 04b80850 by Brandon Chinn at 2023-04-06T03:41:21-04:00 Fix reverse flag for -Wunsupported-llvm-version - - - - - 0c990e13 by Pierre Le Marre at 2023-04-06T10:16:29+00:00 Add release note for GHC.Unicode refactor in base-4.18. Also merge CLC proposal 130 in base-4.19 with CLC proposal 59 in base-4.18 and add proper release date. - - - - - cbbfb283 by Alex Dixon at 2023-04-07T18:27:45-04:00 Improve documentation for ($) (#22963) - - - - - 5193c2b0 by Alex Dixon at 2023-04-07T18:27:45-04:00 Remove trailing whitespace from ($) commentary - - - - - b384523b by Sebastian Graf at 2023-04-07T18:27:45-04:00 Adjust wording wrt representation polymorphism of ($) - - - - - 6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00 Add structured error messages for GHC.Tc.TyCl.Utils Tracking ticket: #20117 MR: !10251 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00 Renamer: don't call addUsedGRE on an exact Name When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc, we could end up calling addUsedGRE on an exact Name, which would then lead to a panic in the bestImport function: it would be incapable of processing a GRE which is not local but also not brought into scope by any imports (as it is referred to by its unique instead). Fixes #23240 - - - - - bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00 Set base 'maintainer' field to CLC - - - - - ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00 Clarify a couple of Notes about 'nospec' - - - - - ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 1599b4cf by Matthew Pickering at 2023-05-05T09:39:15+01:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - f6d990ae by Aaron Allen at 2023-05-05T09:43:21+01:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - af51225b by Matthew Pickering at 2023-05-05T09:43:40+01:00 docs: Add Note [Timing of plugin initialization] - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/generate_job_metadata - .gitlab/generate_jobs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - .gitmodules - cabal.project-reinstall - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/Wasm/Types.hs - compiler/GHC/CmmToAsm/Wasm/Utils.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core/ConLike.hs - compiler/GHC/Core/DataCon.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c42f3a0016dfceb66cd4fc35023734e6edfbf97e...af51225b02bc2e45184df685e87d8be74936db6e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c42f3a0016dfceb66cd4fc35023734e6edfbf97e...af51225b02bc2e45184df685e87d8be74936db6e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 09:24:30 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 05 May 2023 05:24:30 -0400 Subject: [Git][ghc/ghc][wip/T23307] 18 commits: Add sized primitive literal syntax Message-ID: <6454cb4ea6303_e3e0627131c04330018@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23307 at Glasgow Haskell Compiler / GHC Commits: 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - f2f01568 by Simon Peyton Jones at 2023-05-05T10:26:25+01:00 Make GHC.Types.Id.Make.shouldUnpackTy a bit more clever As #23307, GHC.Types.Id.Make.shouldUnpackTy was leaving money on the table, failing to unpack arguments that are perfectly unpackable. The fix is pretty easy; see Note [Recursive unboxing] - - - - - 30 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Unit/Types.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Setup.hs - compiler/ghc.cabal.in - docs/users_guide/9.8.1-notes.rst - + docs/users_guide/exts/extended_literals.rst - docs/users_guide/exts/literals.rst - docs/users_guide/exts/primitives.rst - docs/users_guide/exts/stolen_syntax.rst The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/76cb9a77b1088e3e4141174ea7d2cb18200b4ac1...f2f015689111c7a321063ddce403ba8ddf35b76a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/76cb9a77b1088e3e4141174ea7d2cb18200b4ac1...f2f015689111c7a321063ddce403ba8ddf35b76a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 09:33:28 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 05 May 2023 05:33:28 -0400 Subject: [Git][ghc/ghc][wip/23305] 20 commits: Add sized primitive literal syntax Message-ID: <6454cd68aa38f_e3e062274ca1c3324b1@gitlab.mail> Matthew Pickering pushed to branch wip/23305 at Glasgow Haskell Compiler / GHC Commits: 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - a0f5c55a by Matthew Pickering at 2023-05-05T10:33:18+01:00 Fix behaviour of -keep-tmp-files when used in OPTIONS_GHC pragma This fixes the behaviour of -keep-tmp-files when used in an OPTIONS_GHC pragma for files with module level scope. Instead of simple not deleting the files, we also need to remove them from the TmpFs so they are not deleted later on when all the other files are deleted. There are additional complications because you also need to remove the directory where these files live from the TmpFs so we don't try to delete those later either. I added two tests. 1. Tests simply that -keep-tmp-files works at all with a single module and --make mode. 2. The other tests that temporary files are deleted for other modules which don't enable -keep-tmp-files. Fixes #23339 - - - - - 4d1d819a by Matthew Pickering at 2023-05-05T10:33:18+01:00 withDeferredDiagnostics: When debugIsOn, write landmine into IORef to catch use-after-free. Ticket #23305 reports an error where we were attempting to use the logger which was created by withDeferredDiagnostics after its scope had ended. This problem would have been caught by this patch and a validate build: ``` +*** Exception: Use after free +CallStack (from HasCallStack): + error, called at compiler/GHC/Driver/Make.hs:<line>:<column> in <package-id>:GHC.Driver.Make ``` This general issue is tracked by #20981 - - - - - 1315c369 by Matthew Pickering at 2023-05-05T10:33:18+01:00 Don't return complete HscEnv from upsweep By returning a complete HscEnv from upsweep the logger (as introduced by withDeferredDiagnostics) was escaping the scope of withDeferredDiagnostics and hence we were losing error messages. This is reminiscent of #20981, which also talks about writing errors into messages after their scope has ended. See #23305 for details. - - - - - 30 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/TmpFs.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Setup.hs - compiler/ghc.cabal.in - docs/users_guide/9.8.1-notes.rst - + docs/users_guide/exts/extended_literals.rst - docs/users_guide/exts/literals.rst - docs/users_guide/exts/primitives.rst The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/384c9a2f0ce460d2f167f2dfc9fe6d823db580e4...1315c369203302fcba8f4f5966bf0d834b93b866 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/384c9a2f0ce460d2f167f2dfc9fe6d823db580e4...1315c369203302fcba8f4f5966bf0d834b93b866 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 09:39:33 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 05 May 2023 05:39:33 -0400 Subject: [Git][ghc/ghc][wip/t22884] 20 commits: Add sized primitive literal syntax Message-ID: <6454ced588a84_e3e0627cadfb03366ce@gitlab.mail> Matthew Pickering pushed to branch wip/t22884 at Glasgow Haskell Compiler / GHC Commits: 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 15818aa1 by Matthew Pickering at 2023-05-05T10:38:51+01:00 Introduce GHCiMessage to wrap GhcMessage By introducing a wrapped message type we can control how certain messages are printed in GHCi (to add extra information for example) - - - - - 6abc6b6e by Matthew Pickering at 2023-05-05T10:38:51+01:00 Abstract cantFindError and turn Opt_BuildingCabal into a print-time option * cantFindError is abstracted so that the parts which mention specific things about ghc/ghci are parameters. The intention being that GHC/GHCi can specify the right values to put here but otherwise display the same error message. * The BuildingCabalPackage argument from GenericMissing is removed and turned into a print-time option. The reason for the error is not dependent on whether `-fbuilding-cabal-package` is passed, so we don't want to store that in the error message. - - - - - 32e4ef8e by Matthew Pickering at 2023-05-05T10:39:15+01:00 error messages: Don't display ghci specific hints for missing packages I am unsure about whether the approach taken here is the best of most maintainable solution. I put it up here for review and comment. Fixes #22884 - - - - - 30 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Config/Diagnostic.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Unit/Types.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Setup.hs - compiler/ghc.cabal.in - docs/users_guide/9.8.1-notes.rst - + docs/users_guide/exts/extended_literals.rst The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ca31f4164adeb6393aa249d633f548bf775399f...32e4ef8e2a813e4c01776c134eea348dc542ad17 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ca31f4164adeb6393aa249d633f548bf775399f...32e4ef8e2a813e4c01776c134eea348dc542ad17 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 09:42:17 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Fri, 05 May 2023 05:42:17 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/sand-witch/modern-STV-extension-shuffling Message-ID: <6454cf791c7cc_e3e06250e057c3371fc@gitlab.mail> Andrei Borzenkov pushed new branch wip/sand-witch/modern-STV-extension-shuffling at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sand-witch/modern-STV-extension-shuffling You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 11:18:27 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 05 May 2023 07:18:27 -0400 Subject: [Git][ghc/ghc][wip/t22884] Changes to make :load work with ghci messages Message-ID: <6454e60346f48_e3e0622b3d298353472@gitlab.mail> Matthew Pickering pushed to branch wip/t22884 at Glasgow Haskell Compiler / GHC Commits: c8d121c4 by Matthew Pickering at 2023-05-05T12:18:13+01:00 Changes to make :load work with ghci messages - - - - - 8 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Tc/Errors/Ppr.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - + testsuite/tests/package/T4806_interactive.script - + testsuite/tests/package/T4806_interactive.stderr - testsuite/tests/package/all.T Changes: ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -329,7 +329,7 @@ buildUnit session cid insts lunit = do mod_graph <- hsunitModuleGraph False (unLoc lunit) msg <- mkBackpackMsg - ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph + ok <- load' noIfaceCache LoadAllTargets AnyDiagnostic (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags @@ -418,7 +418,7 @@ compileExe lunit = do withBkpExeSession deps_w_rns $ do mod_graph <- hsunitModuleGraph True (unLoc lunit) msg <- mkBackpackMsg - ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph + ok <- load' noIfaceCache LoadAllTargets AnyDiagnostic (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) -- | Register a new virtual unit database containing a single unit ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -16,6 +16,9 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} -- ----------------------------------------------------------------------------- -- @@ -27,7 +30,7 @@ -- ----------------------------------------------------------------------------- module GHC.Driver.Make ( depanal, depanalE, depanalPartial, checkHomeUnitsClosed, - load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache, + load, loadWithCache, load', AnyDiagnostic(..), LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache, instantiationNodes, downsweep, @@ -486,7 +489,7 @@ newIfaceCache = do -- All other errors are reported using the 'defaultWarnErrLogger'. load :: GhcMonad f => LoadHowMuch -> f SuccessFlag -load how_much = loadWithCache noIfaceCache how_much +load how_much = loadWithCache noIfaceCache AnyDiagnostic how_much mkBatchMsg :: HscEnv -> Messager mkBatchMsg hsc_env = @@ -496,11 +499,11 @@ mkBatchMsg hsc_env = else batchMsg -loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag -loadWithCache cache how_much = do +loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> (GhcMessage -> AnyDiagnostic) -> LoadHowMuch -> m SuccessFlag +loadWithCache cache diag_wrapper how_much = do (errs, mod_graph) <- depanalE [] False -- #17459 msg <- mkBatchMsg <$> getSession - success <- load' cache how_much (Just msg) mod_graph + success <- load' cache how_much diag_wrapper (Just msg) mod_graph if isEmptyMessages errs then pure success else throwErrors (fmap GhcDriverMessage errs) @@ -692,8 +695,8 @@ data WorkerLimit -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally -- produced by calling 'depanal'. -load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag -load' mhmi_cache how_much mHscMessage mod_graph = do +load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag +load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } guessOutputFile hsc_env <- getSession @@ -774,7 +777,7 @@ load' mhmi_cache how_much mHscMessage mod_graph = do setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ do hsc_env <- getSession - liftIO $ upsweep worker_limit hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan + liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan setSession hsc_env1 case upsweep_ok of Failed -> loadFinish upsweep_ok @@ -1070,6 +1073,7 @@ data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be au -- into the log queue. , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a , env_messager :: !(Maybe Messager) + , diag_wrapper :: GhcMessage -> AnyDiagnostic } type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a @@ -1247,13 +1251,14 @@ upsweep :: WorkerLimit -- ^ The number of workers we wish to run in parallel -> HscEnv -- ^ The base HscEnv, which is augmented for each module -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to + -> (GhcMessage -> AnyDiagnostic) -> Maybe Messager -> M.Map ModNodeKeyWithUid HomeModInfo -> [BuildPlan] -> IO (SuccessFlag, HscEnv) -upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do +upsweep n_jobs hsc_env hmi_cache diag_rank mHscMessage old_hpt build_plan = do (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan - runPipelines n_jobs hsc_env mHscMessage pipelines + runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines res <- collect_result let completed = [m | Just (Just m) <- res] @@ -2434,13 +2439,27 @@ setHUG :: HomeUnitGraph -> HscEnv -> HscEnv setHUG deps hsc_env = hscUpdateHUG (const $ deps) hsc_env +data AnyDiagnostic where + AnyDiagnostic :: forall b . (DiagnosticOpts b ~ DiagnosticOpts GhcMessage, Diagnostic b) => b -> AnyDiagnostic + +instance Diagnostic AnyDiagnostic where + type DiagnosticOpts AnyDiagnostic = DiagnosticOpts GhcMessage + defaultDiagnosticOpts = defaultDiagnosticOpts @GhcMessage + diagnosticMessage opts (AnyDiagnostic b) = diagnosticMessage opts b + diagnosticReason (AnyDiagnostic b) = diagnosticReason b + diagnosticHints (AnyDiagnostic b) = diagnosticHints b + diagnosticCode (AnyDiagnostic b) = diagnosticCode b + + + + -- | Wrap an action to catch and handle exceptions. -wrapAction :: HscEnv -> IO a -> IO (Maybe a) -wrapAction hsc_env k = do +wrapAction :: (GhcMessage -> AnyDiagnostic) -> HscEnv -> IO a -> IO (Maybe a) +wrapAction msg_wrapper hsc_env k = do let lcl_logger = hsc_logger hsc_env lcl_dynflags = hsc_dflags hsc_env print_config = initPrintConfig lcl_dynflags - let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (srcErrorMessages err) + let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> srcErrorMessages err) -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches` -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to @@ -2490,9 +2509,10 @@ executeInstantiationNode k n deps uid iu = do -- Output of the logger is mediated by a central worker to -- avoid output interleaving msg <- asks env_messager + wrapper <- asks diag_wrapper lift $ MaybeT $ withLoggerHsc k env $ \hsc_env -> let lcl_hsc_env = setHUG deps hsc_env - in wrapAction lcl_hsc_env $ do + in wrapAction wrapper lcl_hsc_env $ do res <- upsweep_inst lcl_hsc_env msg k n uid iu cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) return res @@ -2518,7 +2538,7 @@ executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do hydrated_hsc_env -- Compile the module, locking with a semaphore to avoid too many modules -- being compiled at the same time leading to high memory usage. - wrapAction lcl_hsc_env $ do + wrapAction diag_wrapper lcl_hsc_env $ do res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags return res) @@ -2849,23 +2869,24 @@ label_self thread_name = do CC.labelThread self_tid thread_name -runPipelines :: WorkerLimit -> HscEnv -> Maybe Messager -> [MakeAction] -> IO () +runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () -- Don't even initialise plugins if there are no pipelines -runPipelines _ _ _ [] = return () -runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do +runPipelines _ _ _ _ [] = return () +runPipelines n_job orig_hsc_env diag_wrapper mHscMessager all_pipelines = do liftIO $ label_self "main --make thread" plugins_hsc_env <- initializePlugins orig_hsc_env case n_job of - NumProcessorsLimit n | n <= 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines - _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines + NumProcessorsLimit n | n <= 1 -> runSeqPipelines plugins_hsc_env diag_wrapper mHscMessager all_pipelines + _n -> runParPipelines n_job plugins_hsc_env diag_wrapper mHscMessager all_pipelines -runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO () -runSeqPipelines plugin_hsc_env mHscMessager all_pipelines = +runSeqPipelines :: HscEnv -> (GhcMessage -> AnyDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () +runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines = let env = MakeEnv { hsc_env = plugin_hsc_env , withLogger = \_ k -> k id , compile_sem = AbstractSem (return ()) (return ()) , env_messager = mHscMessager + , diag_wrapper = diag_wrapper } in runAllPipelines (NumProcessorsLimit 1) env all_pipelines @@ -2895,10 +2916,11 @@ runWorkerLimit worker_limit action = case worker_limit of -- | Build and run a pipeline runParPipelines :: WorkerLimit -- ^ How to limit work parallelism -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module + -> (GhcMessage -> AnyDiagnostic) -> Maybe Messager -- ^ Optional custom messager to use to report progress -> [MakeAction] -- ^ The build plan for all the module nodes -> IO () -runParPipelines worker_limit plugin_hsc_env mHscMessager all_pipelines = do +runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do -- A variable which we write to when an error has happened and we have to tell the @@ -2920,6 +2942,7 @@ runParPipelines worker_limit plugin_hsc_env mHscMessager all_pipelines = do , withLogger = withParLog log_queue_queue_var , compile_sem = abstract_sem , env_messager = mHscMessager + , diag_wrapper = diag_wrapper } -- Reset the number of capabilities once the upsweep ends. runAllPipelines worker_limit env all_pipelines ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -21,6 +21,10 @@ module GHC.Tc.Errors.Ppr , inHsDocContext , TcRnMessageOpts(..) , pprTyThingUsedWrong + + -- | Useful when overriding message printing. + , messageWithInfoDiagnosticMessage + , messageWithHsDocContext ) where @@ -127,12 +131,8 @@ instance Diagnostic TcRnMessage where (tcOptsShowContext opts) (diagnosticMessage opts msg) TcRnWithHsDocContext ctxt msg - -> if tcOptsShowContext opts - then main_msg `unionDecoratedSDoc` ctxt_msg - else main_msg - where - main_msg = diagnosticMessage opts msg - ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt) + -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg) + TcRnSolverReport msg _ _ -> mkSimpleDecorated $ pprSolverReportWithCtxt msg TcRnRedundantConstraints redundants (info, show_info) @@ -3130,6 +3130,14 @@ messageWithInfoDiagnosticMessage unit_state ErrInfo{..} show_ctxt important = in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` mkDecorated err_info' +messageWithHsDocContext :: TcRnMessageOpts -> HsDocContext -> DecoratedSDoc -> DecoratedSDoc +messageWithHsDocContext opts ctxt main_msg = do + if tcOptsShowContext opts + then main_msg `unionDecoratedSDoc` ctxt_msg + else main_msg + where + ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt) + dodgy_msg :: Outputable ie => SDoc -> GlobalRdrElt -> ie -> SDoc dodgy_msg kind tc ie = vcat [ text "The" <+> kind <+> text "item" <+> quotes (ppr ie) <+> text "suggests that" ===================================== ghc/GHCi/UI.hs ===================================== @@ -52,7 +52,7 @@ import GHC.Driver.Session as DynFlags import GHC.Driver.Ppr hiding (printForUser) import GHC.Utils.Error hiding (traceCmd) import GHC.Driver.Monad ( modifySession ) -import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) ) +import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..), AnyDiagnostic(..) ) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Diagnostic import qualified GHC @@ -2176,7 +2176,7 @@ doLoad retain_context howmuch = do liftIO $ do hSetBuffering stdout NoBuffering hSetBuffering stderr NoBuffering) $ \_ -> do hmis <- ifaceCache <$> getGHCiState - ok <- trySuccess $ GHC.loadWithCache (Just hmis) howmuch + ok <- trySuccess $ GHC.loadWithCache (Just hmis) (AnyDiagnostic . GHCiMessage) howmuch afterLoad ok retain_context return ok ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -1,7 +1,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module GHCi.UI.Exception(printGhciException) where +module GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where import GHC.Prelude import GHC.Utils.Logger @@ -49,16 +49,31 @@ instance Diagnostic GHCiMessage where ghciDiagnosticMessage :: GhcMessageOpts -> GhcMessage -> DecoratedSDoc ghciDiagnosticMessage ghc_opts msg = case msg of - GhcTcRnMessage (TcRnInterfaceError err) -> - case ghciInterfaceError err of - Just sdoc -> mkSimpleDecorated sdoc - Nothing -> diagnosticMessage ghc_opts msg + GhcTcRnMessage msg -> tcRnMessage (tcMessageOpts ghc_opts) msg GhcDriverMessage (DriverInterfaceError err) -> case ghciInterfaceError err of Just sdoc -> mkSimpleDecorated sdoc Nothing -> diagnosticMessage ghc_opts msg - _ -> diagnosticMessage ghc_opts msg + GhcPsMessage {} -> diagnosticMessage ghc_opts msg + GhcDsMessage {} -> diagnosticMessage ghc_opts msg + GhcUnknownMessage {} -> diagnosticMessage ghc_opts msg where + tcRnMessage tc_opts tc_msg = + case tc_msg of + TcRnInterfaceError err -> + case ghciInterfaceError err of + Just sdoc -> mkSimpleDecorated sdoc + Nothing -> diagnosticMessage ghc_opts msg + TcRnMessageWithInfo unit_state msg_with_info -> + case msg_with_info of + TcRnMessageDetailed err_info wrapped_msg + -> messageWithInfoDiagnosticMessage unit_state err_info + (tcOptsShowContext tc_opts) + (tcRnMessage tc_opts wrapped_msg) + TcRnWithHsDocContext ctxt wrapped_msg -> + messageWithHsDocContext tc_opts ctxt (tcRnMessage tc_opts wrapped_msg) + _ -> diagnosticMessage ghc_opts msg + opts = tcOptsIfaceOpts (tcMessageOpts ghc_opts) ghciInterfaceError (Can'tFindInterface err looking_for) = ===================================== testsuite/tests/package/T4806_interactive.script ===================================== @@ -0,0 +1,3 @@ +:set -ignore-package containers + +:l T4806.hs ===================================== testsuite/tests/package/T4806_interactive.stderr ===================================== @@ -0,0 +1,6 @@ + +T4806.hs:1:1: error: [GHC-87110] + Could not load module ‘Data.Map’. + It is a member of the package ‘containers-0.6.7’ + which is ignored due to an -ignore-package flag + Use :set -v to see a list of the files searched for. ===================================== testsuite/tests/package/all.T ===================================== @@ -22,3 +22,4 @@ test('T4806', normalise_version('containers'), compile_fail, ['-ignore-package c test('T4806a', normalise_version('deepseq', 'containers', 'template-haskell'), compile_fail, ['-ignore-package deepseq']) test('T22884', normalise_version('text'), compile_fail, ['-hide-package text']) test('T22884_interactive', normalise_version('text'), ghci_script, ['T22884_interactive.script']) +test('T4806_interactive', [extra_files(['T4806.hs']), normalise_version('containers')], ghci_script, ['T4806_interactive.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8d121c46fe63cdff2324d09b882978e0b815012 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c8d121c46fe63cdff2324d09b882978e0b815012 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 11:44:37 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 05 May 2023 07:44:37 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/dynamic-alpine Message-ID: <6454ec25dbe35_e3e06193e5e04358483@gitlab.mail> Matthew Pickering pushed new branch wip/dynamic-alpine at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dynamic-alpine You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 12:10:33 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 08:10:33 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 14 commits: hadrian: Flavour: Change args -> extraArgs Message-ID: <6454f239a2013_e3e06250e057c3604b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 53c2d50d by Oleg Grenrus at 2023-05-05T08:10:28-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - 28 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Unit/Types.hs - compiler/Setup.hs - compiler/ghc.cabal.in - hadrian/bindist/Makefile The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/69c7254e382f9ac2b5eaa01cd83a31543fa3cb8a...53c2d50d425d31e6aa1bc927df57e5f82e7d9d51 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/69c7254e382f9ac2b5eaa01cd83a31543fa3cb8a...53c2d50d425d31e6aa1bc927df57e5f82e7d9d51 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 12:17:29 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 05 May 2023 08:17:29 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/T23333 Message-ID: <6454f3d92104_e3e0622b3d29836576d@gitlab.mail> Simon Peyton Jones pushed new branch wip/T23333 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T23333 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 13:02:31 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Fri, 05 May 2023 09:02:31 -0400 Subject: [Git][ghc/ghc][wip/T23146] 3 commits: Make LFInfos for DataCons on construction Message-ID: <6454fe6717458_e3e062274ca1c374754@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: e26dd90b by Rodrigo Mesquita at 2023-05-05T13:57:30+01:00 Make LFInfos for DataCons on construction As a result of the discussion in !10165, we decided to amend the previous commit which fixed the logic of `mkLFImported` with regard to datacon workers and wrappers. Instead of having the logic for the LFInfo of datacons be in `mkLFImported`, we now construct an LFInfo for all data constructors on GHC.Types.Id.Make and store it in the `lfInfo` field. See the new Note [LFInfo of DataCon workers and wrappers] and ammendments to Note [The LFInfo of Imported Ids] - - - - - 7f021916 by Rodrigo Mesquita at 2023-05-05T13:58:14+01:00 Update Note [Core letrec invariant] Authored by @simonpj - - - - - 38c30187 by Rodrigo Mesquita at 2023-05-05T13:58:49+01:00 Rename mkLFImported to importedIdLFInfo The `mkLFImported` sounded too much like a constructor of sorts, when really it got the `LFInfo` of an imported Id from its `lf_info` field when this existed, and otherwise returned a conservative estimate of that imported Id's LFInfo. This in contrast to functions such as `mkLFReEntrant` which really are about constructing an `LFInfo`. - - - - - 9 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Types.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -368,18 +368,37 @@ Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Core letrec invariant: - The right hand sides of all - /top-level/ or /recursive/ - bindings must be of lifted type - - There is one exception to this rule, top-level @let at s are - allowed to bind primitive string literals: see - Note [Core top-level string literals]. + The right hand sides of all /top-level/ or /recursive/ + bindings must be of lifted type See "Type#type_classification" in GHC.Core.Type -for the meaning of "lifted" vs. "unlifted"). - -For the non-top-level, non-recursive case see Note [Core let-can-float invariant]. +for the meaning of "lifted" vs. "unlifted". + +For the non-top-level, non-recursive case see +Note [Core let-can-float invariant]. + +At top level, however, there are two exceptions to this rule: + +(TL1) A top-level binding is allowed to bind primitive string literal, + (which is unlifted). See Note [Core top-level string literals]. + +(TL2) In CorePrep, we generate a top-level binding for every non-newtype data +constructor worker or wrapper + e.g. data T = MkT Int + we generate + MkT :: Int -> T + MkT = \x. MkT x + (This binding looks recursive, but isn't; it defines a top-level, curried + function whose body just allocates and returns the data constructor.) + + But if (a) the data contructor is nullary and (b) the data type is unlifted, + this binding is unlifted. + e.g. data S :: UnliftedType where { S1 :: S, S2 :: S -> S } + we generate + S1 :: S -- A top-level unlifted binding + S1 = S1 + We allow this top-level unlifted binding to exist, after CorePrep + only. Note [Core let-can-float invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -586,12 +586,19 @@ Function call 'dataConKindEqSpec' returns [k'~k] Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~ -A `DataCon`'s source arity and core representation arity may differ: -`dcSourceArity` does not take constraints into account, but `dcRepArity` does. - -The additional arguments taken into account by `dcRepArity` include quantified -dictionaries and coercion arguments, lifted and unlifted (despite the unlifted -coercion arguments having a zero-width runtime representation). +A `DataCon`'s source and core representation may differ, meaning the source +arity (`dcSourceArity`) and the core representation arity (`dcRepArity`) may +differ too. + +Note that the source arity is the number of arguments the data constructor has +at its source level, which is also the number of arguments the data con +/wrapper/ has. On the other hand, the Core representation arity is the number +of arguments of the data constructor in its Core representation, which is also +the number of arguments of the data con /worker/. + +The arity might differ since `dcRepArity` takes into account arguments such as +quantified dictionaries and coercion arguments, lifted and unlifted (despite +the unlifted coercion arguments having a zero-width runtime representation). For example: MkT :: Ord a => a -> T a dcSourceArity = 1 @@ -601,6 +608,15 @@ For example: dcSourceArity = 0 dcRepArity = 1 +The arity might also differ due to unpacking, for example, consider the +following datatype and its wrapper and worker's type: + data V = MkV !() !Int + $WV :: () -> Int -> V + V :: Int# -> V +As you see, because of unpacking we have both dropped the unit argument and +unboxed the Int. In this case, the source arity (which is the arity of the +wrapper) is 2, while the Core representation arity (the arity of the worker) is 1. + Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -36,7 +36,7 @@ import GHC.Core ( AltCon(..) ) import GHC.Core.Type import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (mkLFImported) +import GHC.StgToCmm.Closure (importedIdLFInfo) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -271,11 +271,11 @@ isTagged v = do TagProper -> True TagTagged -> True TagTuple _ -> True -- Consider unboxed tuples tagged. - False -- Imported - -> return $! + -- Imported + False -> return $! -- Determine whether it is tagged from the LFInfo of the imported id. -- See Note [The LFInfo of Imported Ids] - case mkLFImported v of + case importedIdLFInfo v of -- Function, applied not entered. LFReEntrant {} -> True ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -28,7 +28,7 @@ module GHC.StgToCmm.Closure ( LambdaFormInfo, -- Abstract StandardFormInfo, -- ...ditto... mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + mkApLFInfo, importedIdLFInfo, mkLFArgument, mkLFLetNoEscape, mkLFStringLit, lfDynTag, isLFThunk, isLFReEntrant, lfUpdatable, @@ -96,6 +96,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc +import GHC.Data.Maybe (isNothing) import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 @@ -255,130 +256,67 @@ mkApLFInfo id upd_flag arity (mightBeFunTy (idType id)) ------------- -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id = +-- | The 'LambdaFormInfo' of an imported Id. +-- See Note [The LFInfo of Imported Ids] +importedIdLFInfo :: Id -> LambdaFormInfo +importedIdLFInfo id = -- See Note [Conveying CAF-info and LFInfo between modules] in -- GHC.StgToCmm.Types case idLFInfo_maybe id of Just lf_info -> - -- Use the LambdaFormInfo from the interface + -- Use the existing LambdaFormInfo lf_info Nothing - -- Interface doesn't have a LambdaFormInfo, so make a conservative one from the type. - -- See Note [The LFInfo of Imported Ids]; The order of the guards musn't be changed! + -- Doesn't have a LambdaFormInfo, but we know it must be 'LFReEntrant' from its arity | arity > 0 -> LFReEntrant TopLevel arity True ArgUnknown - | Just con <- isDataConId_maybe id - -- See Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] in GHC.StgToCmm.Types - -- and Note [The LFInfo of Imported Ids] below - -> assert (hasNoNonZeroWidthArgs con) $ - LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor - + -- We can't be sure of the LambdaFormInfo of this imported Id, + -- so make a conservative one from the type. | otherwise - -> mkLFArgument id -- Not sure of exact arity + -> assert (isNothing (isDataConId_maybe id)) $ -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make + mkLFArgument id -- Not sure of exact arity where arity = idFunRepArity id - hasNoNonZeroWidthArgs = all (isZeroBitTy . scaledThing) . dataConRepArgTys {- Note [The LFInfo of Imported Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Conveying CAF-info and LFInfo between modules] and -Note [Imported unlifted nullary datacon wrappers must have correct LFInfo], the -LambdaFormInfo records the details of a closure representation and is often, -when optimisations are enabled, serialized to the interface of a module. - -In particular, the `lfInfo` field of the `IdInfo` field of an `Id` -* For Ids defined in this module: is `Nothing` -* For imported Ids: +As explained in Note [Conveying CAF-info and LFInfo between modules] +the LambdaFormInfo records the details of a closure representation and is +often, when optimisations are enabled, serialized to the interface of a module. + +In particular, the `lfInfo` field of the `IdInfo` field of an `Id`: +* For DataCon workers and wrappers is populated as described in +Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make +* For other Ids defined in the module being compiled: is `Nothing` +* For other imported Ids: * is (Just lf_info) if the LFInfo was serialised into the interface file (typically, when the exporting module was compiled with -O) * is Nothing if it wasn't serialised -However, when an interface doesn't have a LambdaFormInfo for some imported Id -(so that its `lfInfo` field is `Nothing`), we can conservatively create one -using `mkLFImported`. - The LambdaFormInfo we give an Id is used in determining how to tag its pointer -(see `litIdInfo`). Therefore, it's crucial we re-construct a LambdaFormInfo as -faithfully as possible or otherwise risk having pointers incorrectly tagged, -which can lead to performance issues and even segmentation faults (see #23231 -and #23146). In particular, saturated data constructor applications *must* be -unambiguously given `LFCon`, and the invariant - - If the LFInfo (serialised or built with mkLFImported) says LFCon, then it - really is a static data constructor, and similar for LFReEntrant - -must be upheld. - -In `mkLFImported`, we make a conservative approximation to the real -LambdaFormInfo as follows: - -(1) Ids with an `idFunRepArity > 0` are `LFReEntrant` and pointers to them are -tagged (by `litIdInfo`) with the corresponding arity. - - This is also true of data con wrappers and workers with arity > 0, - regardless of the runtime relevance of the arguments - - For example, `Just :: a -> Maybe a` is given `LFReEntrant` - and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too - -(2) Data constructors with `idFunRepArity == 0` should be given `LFCon` because -they are fully saturated data constructor applications and pointers to them -should be tagged with the constructor index. - -(2.1) A datacon *wrapper* with zero arity must be a fully saturated application -of the worker to zero-width arguments only (which are dropped after unarisation) - -(2.2) A datacon *worker* with zero arity is trivially fully saturated, it takes -no arguments whatsoever (not even zero-width args) - -To ensure we properly give `LFReEntrant` to data constructors with some arity, -and `LFCon` only to data constructors with zero arity, we must first check for -`arity > 0` and only afterwards `isDataConId` -- the order of the guards in -`mkLFImported` is quite important. - -As an example, consider the following data constructors: - - data T1 a where - TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a - - data T2 a where - TCon2 :: {-# UNPACK #-} !() -> T2 a - - data T3 a where - TCon3 :: T3 '[] - -`TCon1`'s wrapper has a lifted equality argument, which is non-zero-width, while -the worker has an unlifted equality argument, which is zero-width. - -`TCon2`'s wrapper has a lifted equality argument, which is non-zero-width, -while the worker has no arguments. - -`TCon3`'s wrapper has no arguments, and the worker has 1 zero-width argument; -their Core representation: - - $WTCon3 :: T3 '[] - $WTCon3 = TCon3 @[] - - TCon3 :: forall (a :: * -> *). (a ~# []) => T a - TCon3 = /\a. \(co :: a~#[]). TCon3 co - -For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they -both have arity == 1. - -For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 -while the worker is `LFCon` since its arity == 0 - -For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the -worker `LFReEntrant` since its arity == 1 - -One might think we could give *workers* with only zero-width-args the `LFCon` -LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. -However, these workers, albeit rarely used, are unambiguously functions --- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. -See also the discussion in #23158. +(see `litIdInfo` and `lfDynTag`). Therefore, it's crucial we attribute a correct +LambdaFormInfo to imported Ids, or otherwise risk having pointers incorrectly +tagged which can lead to performance issues and even segmentation faults (see +#23231 and Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]). + +In particular, saturated data constructor applications *must* be unambiguously +given `LFCon`, and if the LFInfo says LFCon, then it really is a static data +constructor, and similar for LFReEntrant. + +In `importedIdLFInfo`, we construct a LambdaFormInfo for imported Ids as follows: + +(1) If the `lfInfo` field contains an LFInfo, we use that LFInfo which is +correct by construction (the invariant being that if it exists, it is correct): + (1.1) Either it was serialised to the interface we're importing the Id from, + (1.2) Or it's a DataCon worker or wrapper and its LFInfo was constructed + according to Note [LFInfo of DataCon workers and wrappers] +(2) When the `lfInfo` field is `Nothing` + (2.1) If the `idFunRepArity` of the Id is known and is greater than 0, then + the Id is unambiguously a function and is given `LFReEntrant`, and pointers + to this Id will be tagged (by `litIdInfo`) with the corresponding arity. + (2.2) Otherwise, we can make a conservative estimate from the type. -} ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -149,7 +149,7 @@ getCgIdInfo id | otherwise = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) in return $ - litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) + litIdInfo platform id (importedIdLFInfo id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug, id is neither in local binds nor is external }}} ===================================== compiler/GHC/StgToCmm/Types.hs ===================================== @@ -53,7 +53,7 @@ make a conservative assumption, but that is bad: e.g. #16559, #15155, and wiki: commentary/rts/haskell-execution/pointer-tagging Conservative assumption here is made when we import an Id without a - LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.mkLFImported. + LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.importedIdLFInfo. So we arrange to always serialise this information into the interface file. The moving parts are: @@ -109,11 +109,9 @@ pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage of the unlifted nature of its arguments by omitting handling of the zero tag when scrutinising them. -The fix is straightforward: extend the logic in `mkLFImported` to cover -(nullary) datacon wrappers as well as workers. This is safe because we -know that the wrapper of a nullary datacon will be in WHNF, even if it -includes equalities evidence (since such equalities are not runtime -relevant). This fixed #23146. +The fix is straightforward: ensure we always construct a /correct/ LFInfo for +datacon workers and wrappers, and populate the `lfInfo` with it. See +Note [LFInfo of DataCon workers and wrappers]. This fixed #23146. See also Note [The LFInfo of Imported Ids] -} ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -120,7 +120,8 @@ infixl 1 `setRuleInfo`, `setCafInfo`, `setDmdSigInfo`, `setCprSigInfo`, - `setDemandInfo` + `setDemandInfo`, + `setLFInfo` {- ************************************************************************ * * @@ -374,7 +375,12 @@ data IdInfo -- -- See documentation of the getters for what these packed fields mean. lfInfo :: !(Maybe LambdaFormInfo), - -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure + -- ^ If lfInfo = Just info, then the `info` is guaranteed /correct/. + -- If lfInfo = Nothing, then we do not have a `LambdaFormInfo` for this Id, + -- so (for imported Ids) we make a conservative version. + -- See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure + -- For locally-defined Ids other than DataCons, the `lfInfo` field is always Nothing. + -- See also Note [LFInfo of DataCon workers and wrappers] -- See documentation of the getters for what these packed fields mean. tagSig :: !(Maybe TagSig) ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -65,6 +65,7 @@ import GHC.Core.DataCon import GHC.Types.Literal import GHC.Types.SourceText +import GHC.Types.RepType ( countFunRepArgs ) import GHC.Types.Name.Set import GHC.Types.Name import GHC.Types.ForeignCall @@ -87,6 +88,10 @@ import GHC.Data.FastString import GHC.Data.List.SetOps import Data.List ( zipWith4 ) +-- A bit of a shame we must import these here +import GHC.StgToCmm.Types (LambdaFormInfo(..)) +import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown)) + {- ************************************************************************ * * @@ -595,11 +600,18 @@ mkDataConWorkId wkr_name data_con `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 + `setLFInfo` wkr_lf_info -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con + -- See Note [LFInfo of DataCon workers and wrappers] + wkr_lf_info + | wkr_arity == 0 = LFCon data_con + | otherwise = LFReEntrant TopLevel (countFunRepArgs wkr_arity wkr_ty) True ArgUnknown + -- LFInfo stores post-unarisation arity + ----------- Workers for newtypes -------------- univ_tvs = dataConUnivTyVars data_con ex_tcvs = dataConExTyCoVars data_con @@ -608,6 +620,7 @@ mkDataConWorkId wkr_name data_con `setArityInfo` 1 -- Arity 1 `setInlinePragInfo` dataConWrapperInlinePragma `setUnfoldingInfo` newtype_unf + `setLFInfo` (LFReEntrant TopLevel 1 True ArgUnknown) id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) res_ty_args = mkTyCoVarTys univ_tvs newtype_unf = assertPpr (null ex_tcvs && isSingleton arg_tys) @@ -618,6 +631,82 @@ mkDataConWorkId wkr_name data_con wrapNewTypeBody tycon res_ty_args (Var id_arg1) {- +Note [LFInfo of DataCon workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure, it's +crucial that saturated data con applications are given an LFInfo of `LFCon`. + +Since for data constructors we never serialise the worker and the wrapper (only +the data type declaration), we never serialise their lambda form info either. + +Therefore, when making data constructors workers and wrappers, we construct a +correct `LFInfo` for them right away, and put it it in the `lfInfo` field of the +worker/wrapper Id, ensuring that: + + The `lfInfo` field of a DataCon worker or wrapper is always populated with the correct LFInfo. + +How do we construct a /correct/ LFInfo for workers and wrappers? +(Remember: `LFCon` means "a saturated constructor application") + +(1) Data constructor workers and wrappers with arity > 0 are unambiguously +functions and should be given `LFReEntrant`, regardless of the runtime +relevance of the arguments. + - For example, `Just :: a -> Maybe a` is given `LFReEntrant`, + and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too. + +(2) A datacon /worker/ with zero arity is trivially fully saturated -- it takes +no arguments whatsoever (not even zero-width args), so it is given `LFCon`. + +(3) Perhaps surprisingly, a datacon /wrapper/ can be an `LFCon`. See Wrinkle (W1) below. +A datacon /wrapper/ with zero arity must be a fully saturated application of +the worker to zero-width arguments only (which are dropped after unarisation), +and therefore is also given `LFCon`. + +For example, consider the following data constructors: + + data T1 a where + TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a + + data T2 a where + TCon2 :: {-# UNPACK #-} !() -> T2 a + + data T3 a where + TCon3 :: T3 '[] + +`TCon1`'s wrapper has a lifted argument, which is non-zero-width, while the +worker has an unlifted equality argument, which is zero-width. + +`TCon2`'s wrapper has a lifted argument, which is non-zero-width, while the +worker has no arguments. + +Wrinkle (W1). Perhaps surprisingly, it is possible for the /wrapper/ to be an +`LFCon` even though the /worker/ is not. Consider `T3` above. Here is the +Core representation of the worker and wrapper: + + $WTCon3 :: T3 '[] -- Wrapper + $WTCon3 = TCon3 @[] -- A saturated constructor application: LFCon + + TCon3 :: forall (a :: * -> *). (a ~# []) => T a -- Worker + TCon3 = /\a. \(co :: a~#[]). TCon3 co -- A function: LFReEntrant + +For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they +both have arity == 1. + +For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 +while the worker is `LFCon` since its arity == 0 + +For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the +worker `LFReEntrant` since its arity == 1 + +One might think we could give *workers* with only zero-width-args the `LFCon` +LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. +However, these workers are unambiguously functions +-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. +See also the discussion in #23158. + +See also the Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] +in GHC.StgToCmm.Types. + ------------------------------------------------- -- Data constructor representation -- @@ -709,11 +798,18 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane + `setLFInfo` wrap_lf_info -- The signature is purely for passes like the Simplifier, not for -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers]. wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv + -- See Note [LFInfo of DataCon workers and wrappers] + wrap_lf_info + | wrap_arity == 0 = LFCon data_con + | otherwise = LFReEntrant TopLevel (countFunRepArgs wrap_arity wrap_ty) True ArgUnknown + -- LFInfo stores post-unarisation arity + wrap_arg_dmds = replicate (length theta) topDmd ++ map mk_dmd arg_ibangs -- Don't forget the dictionary arguments when building ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -124,6 +124,10 @@ unwrapType ty | otherwise = NS_Done +-- | Count the arity of a function post-unarisation, including zero-width arguments. +-- +-- The post-unarisation arity may be larger than the arity of the original +-- function type. See Note [Unarisation]. countFunRepArgs :: Arity -> Type -> RepArity countFunRepArgs 0 _ = 0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7784859d190e75b8fe52df002c0b615c88f0365...38c301872915ac5f33d80927f84eea69292cb156 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b7784859d190e75b8fe52df002c0b615c88f0365...38c301872915ac5f33d80927f84eea69292cb156 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 13:20:07 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Fri, 05 May 2023 09:20:07 -0400 Subject: [Git][ghc/ghc][wip/T23146] Enforce invariant on typePrimRepArgs in the types Message-ID: <6455028795c4f_e3e0627cadfb038133c@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: 749160f9 by Rodrigo Mesquita at 2023-05-05T14:17:34+01:00 Enforce invariant on typePrimRepArgs in the types As part of the documentation effort in !10165 I came across this invariant on 'typePrimRepArgs' which is easily expressed at the type-level through a NonEmpty list. It allowed us to remove one panic. - - - - - 3 changed files: - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -889,12 +889,12 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise = case typePrimRepArgs ty of - [rep_ty] -> do + rep_ty :| [] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys + rep_ty :| rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -81,8 +81,10 @@ import Data.Coerce (coerce) import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap +import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -296,8 +298,8 @@ argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: [ArgRep] -> [ArgRep] -non_void = filter nv +non_void :: NonEmpty ArgRep -> [ArgRep] +non_void = NE.filter nv where nv V = False nv _ = True @@ -464,7 +466,7 @@ returnUnliftedAtom d s p e = do StgLitArg lit -> typePrimRepArgs (literalType lit) StgVarArg i -> bcIdPrimReps i (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb reps + ret <- returnUnliftedReps d s szb (NE.toList reps) return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -867,7 +869,7 @@ doCase d s p scrut bndr alts (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -1660,9 +1662,8 @@ maybe_getCCallReturnRep fn_ty (pprType fn_ty) in case r_reps of - [] -> panic "empty typePrimRepArgs" - [VoidRep] -> Nothing - [rep] -> Just rep + VoidRep :| [] -> Nothing + rep :| [] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -2117,7 +2118,7 @@ idSizeCon platform var isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - bcIdPrimReps $ var + NE.toList . bcIdPrimReps $ var | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) bcIdArgRep :: Platform -> Id -> ArgRep @@ -2125,13 +2126,13 @@ bcIdArgRep platform = toArgRep platform . bcIdPrimRep bcIdPrimRep :: Id -> PrimRep bcIdPrimRep id - | [rep] <- typePrimRepArgs (idType id) + | rep :| [] <- typePrimRepArgs (idType id) = rep | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) -bcIdPrimReps :: Id -> [PrimRep] +bcIdPrimReps :: Id -> NonEmpty PrimRep bcIdPrimReps id = typePrimRepArgs (idType id) repSizeWords :: Platform -> PrimRep -> WordOff @@ -2189,8 +2190,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e) mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> [ArgRep] -typeArgReps platform = map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> NonEmpty ArgRep +typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs -- ----------------------------------------------------------------------------- -- The bytecode generator's monad ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -84,12 +84,11 @@ isNvUnaryType ty = False -- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep] +typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep typePrimRepArgs ty - | [] <- reps - = [VoidRep] - | otherwise - = reps + = case reps of + [] -> VoidRep :| [] + (x:xs) -> x :| xs where reps = typePrimRep ty View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/749160f948016e4342bc770e969d5bfc20596bd2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/749160f948016e4342bc770e969d5bfc20596bd2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 14:04:41 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Fri, 05 May 2023 10:04:41 -0400 Subject: [Git][ghc/ghc][wip/T23146] Merge outdated Note [Data con representation] into Note [Data constructor representation] Message-ID: <64550cf9bfb4b_e3e062c59e10c388084@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: 94db0835 by Rodrigo Mesquita at 2023-05-05T15:02:35+01:00 Merge outdated Note [Data con representation] into Note [Data constructor representation] Introduce new Note [Constructor applications in STG] to better support the merge, and reference it from the relevant bits in the STG syntax. - - - - - 2 changed files: - compiler/GHC/Core/DataCon.hs - compiler/GHC/Stg/Syntax.hs Changes: ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -141,7 +141,19 @@ becomes case e of { T a' b -> let a = I# a' in ... } To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. +differently, as follows in Note [Data Constructor Naming]. + +The `dcRepType` field of a `DataCon` contains the type of the representation of +the constructor /worker/, also called the Core representation. + +The Core representation may differ from the type of the constructor /wrapper/ +(built by `mkDataConId`). Besides unpacking (as seen in the example above), +dictionaries and coercions become explict arguments in the Core representation +of a constructor. + +Note that this representation is still *different* from runtime +representation. (Which is what STG uses after unarise). +See Note [Constructor applications in STG] in GHC.Stg.Syntax. Note [Data Constructor Naming] @@ -528,7 +540,7 @@ data DataCon -- forall a x y. (a~(x,y), x~y, Ord x) => -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) + -- see Note [Data constructor representation]) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: -- case (e :: T t) of @@ -985,51 +997,6 @@ we consult HsImplBang: The boolean flag is used only for this warning. See #11270 for motivation. -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -So whenever this module talks about the representation of a data constructor -what it means is the DataCon with all Unpacking having been applied. -We can think of this as the Core representation. - -Here's an example illustrating the Core representation: - data Ord a => T a = MkT Int! a Void# -Here - T :: Ord a => Int -> a -> Void# -> T a -but the rep type is - Trep :: Int# -> a -> Void# -> T a -Actually, the unboxed part isn't implemented yet! - -Note that this representation is still *different* from runtime -representation. (Which is what STG uses after unarise). - -This is how T would end up being used in STG post-unarise: - - let x = T 1# y - in ... - case x of - T int a -> ... - -The Void# argument is dropped and the boxed int is replaced by an unboxed -one. In essence we only generate binders for runtime relevant values. - -We also flatten out unboxed tuples in this process. See the unarise -pass for details on how this is done. But as an example consider -`data S = MkS Bool (# Bool | Char #)` which when matched on would -result in an alternative with three binders like this - - MkS bool tag tpl_field -> - -See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] -for the details of this transformation. - ************************************************************************ * * ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -237,6 +237,50 @@ StgConApp and StgPrimApp --- saturated applications There are specialised forms of application, for constructors, primitives, and literals. + +Note [Constructor applications in STG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In STG, constructor applications `StgConApp` and `StgRhsCon` are always /fully saturated/. +However, the number of arguments saturating the application may differ +post-unarisation because we drop void arguments from `StgConApp` and `StgRhsCon` +constructor applications during unarisation. + +Therefore, in `StgConApp` and `StgRhsCon`: +* Before unarisation, we have the saturated list of the arguments [StgArg] +* Post unarisation, we have the saturated list of non-void arguments, the type +of which should really be [NonVoid StgArg] + +As an example, consider: + + data T a = MkT Int! a Void# + +The wrapper's representation and the worker's representation (i.e. the +datacon's Core representation) are respectively: + + $WT :: Int -> a -> Void# -> T a + T :: Int# -> a -> Void# -> T a + +T would end up being used in STG post-unarise as: + + let x = T 1# y + in ... + case x of + T int a -> ... + +The Void# argument is dropped. In essence we only generate binders for runtime +relevant values. + +We also flatten out unboxed tuples in this process. See the unarise +pass for details on how this is done. But as an example consider +`data S = MkS Bool (# Bool | Char #)` which when matched on would +result in an alternative with three binders like this + + MkS bool tag tpl_field -> + +See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] +for the details of this transformation. + -} | StgLit Literal @@ -245,7 +289,7 @@ literals. -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) + [StgArg] -- Saturated. See Note [Constructor applications in STG] [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call @@ -421,7 +465,7 @@ important): -- are not allocated. ConstructorNumber [StgTickish] - [StgArg] -- Args + [StgArg] -- Saturated Args. See Note [Constructor applications in STG] -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94db08351659f012361c44ff1e9d5224f1407f06 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94db08351659f012361c44ff1e9d5224f1407f06 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 14:33:55 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Fri, 05 May 2023 10:33:55 -0400 Subject: [Git][ghc/ghc][wip/T23146] 5 commits: Make LFInfos for DataCons on construction Message-ID: <645513d397a3a_e3e0627cadfb03948af@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: b3137a58 by Rodrigo Mesquita at 2023-05-05T15:32:58+01:00 Make LFInfos for DataCons on construction As a result of the discussion in !10165, we decided to amend the previous commit which fixed the logic of `mkLFImported` with regard to datacon workers and wrappers. Instead of having the logic for the LFInfo of datacons be in `mkLFImported`, we now construct an LFInfo for all data constructors on GHC.Types.Id.Make and store it in the `lfInfo` field. See the new Note [LFInfo of DataCon workers and wrappers] and ammendments to Note [The LFInfo of Imported Ids] - - - - - cdb20d1b by Rodrigo Mesquita at 2023-05-05T15:33:02+01:00 Update Note [Core letrec invariant] Authored by @simonpj - - - - - 3831cdf5 by Rodrigo Mesquita at 2023-05-05T15:33:02+01:00 Rename mkLFImported to importedIdLFInfo The `mkLFImported` sounded too much like a constructor of sorts, when really it got the `LFInfo` of an imported Id from its `lf_info` field when this existed, and otherwise returned a conservative estimate of that imported Id's LFInfo. This in contrast to functions such as `mkLFReEntrant` which really are about constructing an `LFInfo`. - - - - - 0c4f6796 by Rodrigo Mesquita at 2023-05-05T15:33:02+01:00 Enforce invariant on typePrimRepArgs in the types As part of the documentation effort in !10165 I came across this invariant on 'typePrimRepArgs' which is easily expressed at the type-level through a NonEmpty list. It allowed us to remove one panic. - - - - - f801b269 by Rodrigo Mesquita at 2023-05-05T15:33:02+01:00 Merge outdated Note [Data con representation] into Note [Data constructor representation] Introduce new Note [Constructor applications in STG] to better support the merge, and reference it from the relevant bits in the STG syntax. - - - - - 12 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Types.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -368,18 +368,37 @@ Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Core letrec invariant: - The right hand sides of all - /top-level/ or /recursive/ - bindings must be of lifted type - - There is one exception to this rule, top-level @let at s are - allowed to bind primitive string literals: see - Note [Core top-level string literals]. + The right hand sides of all /top-level/ or /recursive/ + bindings must be of lifted type See "Type#type_classification" in GHC.Core.Type -for the meaning of "lifted" vs. "unlifted"). - -For the non-top-level, non-recursive case see Note [Core let-can-float invariant]. +for the meaning of "lifted" vs. "unlifted". + +For the non-top-level, non-recursive case see +Note [Core let-can-float invariant]. + +At top level, however, there are two exceptions to this rule: + +(TL1) A top-level binding is allowed to bind primitive string literal, + (which is unlifted). See Note [Core top-level string literals]. + +(TL2) In CorePrep, we generate a top-level binding for every non-newtype data +constructor worker or wrapper + e.g. data T = MkT Int + we generate + MkT :: Int -> T + MkT = \x. MkT x + (This binding looks recursive, but isn't; it defines a top-level, curried + function whose body just allocates and returns the data constructor.) + + But if (a) the data contructor is nullary and (b) the data type is unlifted, + this binding is unlifted. + e.g. data S :: UnliftedType where { S1 :: S, S2 :: S -> S } + we generate + S1 :: S -- A top-level unlifted binding + S1 = S1 + We allow this top-level unlifted binding to exist, after CorePrep + only. Note [Core let-can-float invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -141,7 +141,19 @@ becomes case e of { T a' b -> let a = I# a' in ... } To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. +differently, as follows in Note [Data Constructor Naming]. + +The `dcRepType` field of a `DataCon` contains the type of the representation of +the constructor /worker/, also called the Core representation. + +The Core representation may differ from the type of the constructor /wrapper/ +(built by `mkDataConId`). Besides unpacking (as seen in the example above), +dictionaries and coercions become explict arguments in the Core representation +of a constructor. + +Note that this representation is still *different* from runtime +representation. (Which is what STG uses after unarise). +See Note [Constructor applications in STG] in GHC.Stg.Syntax. Note [Data Constructor Naming] @@ -528,7 +540,7 @@ data DataCon -- forall a x y. (a~(x,y), x~y, Ord x) => -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) + -- see Note [Data constructor representation]) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: -- case (e :: T t) of @@ -586,12 +598,19 @@ Function call 'dataConKindEqSpec' returns [k'~k] Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~ -A `DataCon`'s source arity and core representation arity may differ: -`dcSourceArity` does not take constraints into account, but `dcRepArity` does. - -The additional arguments taken into account by `dcRepArity` include quantified -dictionaries and coercion arguments, lifted and unlifted (despite the unlifted -coercion arguments having a zero-width runtime representation). +A `DataCon`'s source and core representation may differ, meaning the source +arity (`dcSourceArity`) and the core representation arity (`dcRepArity`) may +differ too. + +Note that the source arity is the number of arguments the data constructor has +at its source level, which is also the number of arguments the data con +/wrapper/ has. On the other hand, the Core representation arity is the number +of arguments of the data constructor in its Core representation, which is also +the number of arguments of the data con /worker/. + +The arity might differ since `dcRepArity` takes into account arguments such as +quantified dictionaries and coercion arguments, lifted and unlifted (despite +the unlifted coercion arguments having a zero-width runtime representation). For example: MkT :: Ord a => a -> T a dcSourceArity = 1 @@ -601,6 +620,15 @@ For example: dcSourceArity = 0 dcRepArity = 1 +The arity might also differ due to unpacking, for example, consider the +following datatype and its wrapper and worker's type: + data V = MkV !() !Int + $WV :: () -> Int -> V + V :: Int# -> V +As you see, because of unpacking we have both dropped the unit argument and +unboxed the Int. In this case, the source arity (which is the arity of the +wrapper) is 2, while the Core representation arity (the arity of the worker) is 1. + Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -969,51 +997,6 @@ we consult HsImplBang: The boolean flag is used only for this warning. See #11270 for motivation. -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -So whenever this module talks about the representation of a data constructor -what it means is the DataCon with all Unpacking having been applied. -We can think of this as the Core representation. - -Here's an example illustrating the Core representation: - data Ord a => T a = MkT Int! a Void# -Here - T :: Ord a => Int -> a -> Void# -> T a -but the rep type is - Trep :: Int# -> a -> Void# -> T a -Actually, the unboxed part isn't implemented yet! - -Note that this representation is still *different* from runtime -representation. (Which is what STG uses after unarise). - -This is how T would end up being used in STG post-unarise: - - let x = T 1# y - in ... - case x of - T int a -> ... - -The Void# argument is dropped and the boxed int is replaced by an unboxed -one. In essence we only generate binders for runtime relevant values. - -We also flatten out unboxed tuples in this process. See the unarise -pass for details on how this is done. But as an example consider -`data S = MkS Bool (# Bool | Char #)` which when matched on would -result in an alternative with three binders like this - - MkS bool tag tpl_field -> - -See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] -for the details of this transformation. - ************************************************************************ * * ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -889,12 +889,12 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise = case typePrimRepArgs ty of - [rep_ty] -> do + rep_ty :| [] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys + rep_ty :| rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -36,7 +36,7 @@ import GHC.Core ( AltCon(..) ) import GHC.Core.Type import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (mkLFImported) +import GHC.StgToCmm.Closure (importedIdLFInfo) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -271,11 +271,11 @@ isTagged v = do TagProper -> True TagTagged -> True TagTuple _ -> True -- Consider unboxed tuples tagged. - False -- Imported - -> return $! + -- Imported + False -> return $! -- Determine whether it is tagged from the LFInfo of the imported id. -- See Note [The LFInfo of Imported Ids] - case mkLFImported v of + case importedIdLFInfo v of -- Function, applied not entered. LFReEntrant {} -> True ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -237,6 +237,50 @@ StgConApp and StgPrimApp --- saturated applications There are specialised forms of application, for constructors, primitives, and literals. + +Note [Constructor applications in STG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In STG, constructor applications `StgConApp` and `StgRhsCon` are always /fully saturated/. +However, the number of arguments saturating the application may differ +post-unarisation because we drop void arguments from `StgConApp` and `StgRhsCon` +constructor applications during unarisation. + +Therefore, in `StgConApp` and `StgRhsCon`: +* Before unarisation, we have the saturated list of the arguments [StgArg] +* Post unarisation, we have the saturated list of non-void arguments, the type +of which should really be [NonVoid StgArg] + +As an example, consider: + + data T a = MkT Int! a Void# + +The wrapper's representation and the worker's representation (i.e. the +datacon's Core representation) are respectively: + + $WT :: Int -> a -> Void# -> T a + T :: Int# -> a -> Void# -> T a + +T would end up being used in STG post-unarise as: + + let x = T 1# y + in ... + case x of + T int a -> ... + +The Void# argument is dropped. In essence we only generate binders for runtime +relevant values. + +We also flatten out unboxed tuples in this process. See the unarise +pass for details on how this is done. But as an example consider +`data S = MkS Bool (# Bool | Char #)` which when matched on would +result in an alternative with three binders like this + + MkS bool tag tpl_field -> + +See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] +for the details of this transformation. + -} | StgLit Literal @@ -245,7 +289,7 @@ literals. -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) + [StgArg] -- Saturated. See Note [Constructor applications in STG] [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call @@ -421,7 +465,7 @@ important): -- are not allocated. ConstructorNumber [StgTickish] - [StgArg] -- Args + [StgArg] -- Saturated Args. See Note [Constructor applications in STG] -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -81,8 +81,10 @@ import Data.Coerce (coerce) import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap +import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -296,8 +298,8 @@ argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: [ArgRep] -> [ArgRep] -non_void = filter nv +non_void :: NonEmpty ArgRep -> [ArgRep] +non_void = NE.filter nv where nv V = False nv _ = True @@ -464,7 +466,7 @@ returnUnliftedAtom d s p e = do StgLitArg lit -> typePrimRepArgs (literalType lit) StgVarArg i -> bcIdPrimReps i (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb reps + ret <- returnUnliftedReps d s szb (NE.toList reps) return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -867,7 +869,7 @@ doCase d s p scrut bndr alts (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -1660,9 +1662,8 @@ maybe_getCCallReturnRep fn_ty (pprType fn_ty) in case r_reps of - [] -> panic "empty typePrimRepArgs" - [VoidRep] -> Nothing - [rep] -> Just rep + VoidRep :| [] -> Nothing + rep :| [] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -2117,7 +2118,7 @@ idSizeCon platform var isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - bcIdPrimReps $ var + NE.toList . bcIdPrimReps $ var | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) bcIdArgRep :: Platform -> Id -> ArgRep @@ -2125,13 +2126,13 @@ bcIdArgRep platform = toArgRep platform . bcIdPrimRep bcIdPrimRep :: Id -> PrimRep bcIdPrimRep id - | [rep] <- typePrimRepArgs (idType id) + | rep :| [] <- typePrimRepArgs (idType id) = rep | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) -bcIdPrimReps :: Id -> [PrimRep] +bcIdPrimReps :: Id -> NonEmpty PrimRep bcIdPrimReps id = typePrimRepArgs (idType id) repSizeWords :: Platform -> PrimRep -> WordOff @@ -2189,8 +2190,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e) mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> [ArgRep] -typeArgReps platform = map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> NonEmpty ArgRep +typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs -- ----------------------------------------------------------------------------- -- The bytecode generator's monad ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -28,7 +28,7 @@ module GHC.StgToCmm.Closure ( LambdaFormInfo, -- Abstract StandardFormInfo, -- ...ditto... mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + mkApLFInfo, importedIdLFInfo, mkLFArgument, mkLFLetNoEscape, mkLFStringLit, lfDynTag, isLFThunk, isLFReEntrant, lfUpdatable, @@ -96,6 +96,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc +import GHC.Data.Maybe (isNothing) import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 @@ -255,130 +256,67 @@ mkApLFInfo id upd_flag arity (mightBeFunTy (idType id)) ------------- -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id = +-- | The 'LambdaFormInfo' of an imported Id. +-- See Note [The LFInfo of Imported Ids] +importedIdLFInfo :: Id -> LambdaFormInfo +importedIdLFInfo id = -- See Note [Conveying CAF-info and LFInfo between modules] in -- GHC.StgToCmm.Types case idLFInfo_maybe id of Just lf_info -> - -- Use the LambdaFormInfo from the interface + -- Use the existing LambdaFormInfo lf_info Nothing - -- Interface doesn't have a LambdaFormInfo, so make a conservative one from the type. - -- See Note [The LFInfo of Imported Ids]; The order of the guards musn't be changed! + -- Doesn't have a LambdaFormInfo, but we know it must be 'LFReEntrant' from its arity | arity > 0 -> LFReEntrant TopLevel arity True ArgUnknown - | Just con <- isDataConId_maybe id - -- See Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] in GHC.StgToCmm.Types - -- and Note [The LFInfo of Imported Ids] below - -> assert (hasNoNonZeroWidthArgs con) $ - LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor - + -- We can't be sure of the LambdaFormInfo of this imported Id, + -- so make a conservative one from the type. | otherwise - -> mkLFArgument id -- Not sure of exact arity + -> assert (isNothing (isDataConId_maybe id)) $ -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make + mkLFArgument id -- Not sure of exact arity where arity = idFunRepArity id - hasNoNonZeroWidthArgs = all (isZeroBitTy . scaledThing) . dataConRepArgTys {- Note [The LFInfo of Imported Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Conveying CAF-info and LFInfo between modules] and -Note [Imported unlifted nullary datacon wrappers must have correct LFInfo], the -LambdaFormInfo records the details of a closure representation and is often, -when optimisations are enabled, serialized to the interface of a module. - -In particular, the `lfInfo` field of the `IdInfo` field of an `Id` -* For Ids defined in this module: is `Nothing` -* For imported Ids: +As explained in Note [Conveying CAF-info and LFInfo between modules] +the LambdaFormInfo records the details of a closure representation and is +often, when optimisations are enabled, serialized to the interface of a module. + +In particular, the `lfInfo` field of the `IdInfo` field of an `Id`: +* For DataCon workers and wrappers is populated as described in +Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make +* For other Ids defined in the module being compiled: is `Nothing` +* For other imported Ids: * is (Just lf_info) if the LFInfo was serialised into the interface file (typically, when the exporting module was compiled with -O) * is Nothing if it wasn't serialised -However, when an interface doesn't have a LambdaFormInfo for some imported Id -(so that its `lfInfo` field is `Nothing`), we can conservatively create one -using `mkLFImported`. - The LambdaFormInfo we give an Id is used in determining how to tag its pointer -(see `litIdInfo`). Therefore, it's crucial we re-construct a LambdaFormInfo as -faithfully as possible or otherwise risk having pointers incorrectly tagged, -which can lead to performance issues and even segmentation faults (see #23231 -and #23146). In particular, saturated data constructor applications *must* be -unambiguously given `LFCon`, and the invariant - - If the LFInfo (serialised or built with mkLFImported) says LFCon, then it - really is a static data constructor, and similar for LFReEntrant - -must be upheld. - -In `mkLFImported`, we make a conservative approximation to the real -LambdaFormInfo as follows: - -(1) Ids with an `idFunRepArity > 0` are `LFReEntrant` and pointers to them are -tagged (by `litIdInfo`) with the corresponding arity. - - This is also true of data con wrappers and workers with arity > 0, - regardless of the runtime relevance of the arguments - - For example, `Just :: a -> Maybe a` is given `LFReEntrant` - and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too - -(2) Data constructors with `idFunRepArity == 0` should be given `LFCon` because -they are fully saturated data constructor applications and pointers to them -should be tagged with the constructor index. - -(2.1) A datacon *wrapper* with zero arity must be a fully saturated application -of the worker to zero-width arguments only (which are dropped after unarisation) - -(2.2) A datacon *worker* with zero arity is trivially fully saturated, it takes -no arguments whatsoever (not even zero-width args) - -To ensure we properly give `LFReEntrant` to data constructors with some arity, -and `LFCon` only to data constructors with zero arity, we must first check for -`arity > 0` and only afterwards `isDataConId` -- the order of the guards in -`mkLFImported` is quite important. - -As an example, consider the following data constructors: - - data T1 a where - TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a - - data T2 a where - TCon2 :: {-# UNPACK #-} !() -> T2 a - - data T3 a where - TCon3 :: T3 '[] - -`TCon1`'s wrapper has a lifted equality argument, which is non-zero-width, while -the worker has an unlifted equality argument, which is zero-width. - -`TCon2`'s wrapper has a lifted equality argument, which is non-zero-width, -while the worker has no arguments. - -`TCon3`'s wrapper has no arguments, and the worker has 1 zero-width argument; -their Core representation: - - $WTCon3 :: T3 '[] - $WTCon3 = TCon3 @[] - - TCon3 :: forall (a :: * -> *). (a ~# []) => T a - TCon3 = /\a. \(co :: a~#[]). TCon3 co - -For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they -both have arity == 1. - -For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 -while the worker is `LFCon` since its arity == 0 - -For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the -worker `LFReEntrant` since its arity == 1 - -One might think we could give *workers* with only zero-width-args the `LFCon` -LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. -However, these workers, albeit rarely used, are unambiguously functions --- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. -See also the discussion in #23158. +(see `litIdInfo` and `lfDynTag`). Therefore, it's crucial we attribute a correct +LambdaFormInfo to imported Ids, or otherwise risk having pointers incorrectly +tagged which can lead to performance issues and even segmentation faults (see +#23231 and Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]). + +In particular, saturated data constructor applications *must* be unambiguously +given `LFCon`, and if the LFInfo says LFCon, then it really is a static data +constructor, and similar for LFReEntrant. + +In `importedIdLFInfo`, we construct a LambdaFormInfo for imported Ids as follows: + +(1) If the `lfInfo` field contains an LFInfo, we use that LFInfo which is +correct by construction (the invariant being that if it exists, it is correct): + (1.1) Either it was serialised to the interface we're importing the Id from, + (1.2) Or it's a DataCon worker or wrapper and its LFInfo was constructed + according to Note [LFInfo of DataCon workers and wrappers] +(2) When the `lfInfo` field is `Nothing` + (2.1) If the `idFunRepArity` of the Id is known and is greater than 0, then + the Id is unambiguously a function and is given `LFReEntrant`, and pointers + to this Id will be tagged (by `litIdInfo`) with the corresponding arity. + (2.2) Otherwise, we can make a conservative estimate from the type. -} ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -149,7 +149,7 @@ getCgIdInfo id | otherwise = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) in return $ - litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) + litIdInfo platform id (importedIdLFInfo id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug, id is neither in local binds nor is external }}} ===================================== compiler/GHC/StgToCmm/Types.hs ===================================== @@ -53,7 +53,7 @@ make a conservative assumption, but that is bad: e.g. #16559, #15155, and wiki: commentary/rts/haskell-execution/pointer-tagging Conservative assumption here is made when we import an Id without a - LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.mkLFImported. + LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.importedIdLFInfo. So we arrange to always serialise this information into the interface file. The moving parts are: @@ -75,9 +75,25 @@ Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As described in `Note [Conveying CAF-info and LFInfo between modules]`, imported unlifted nullary datacons must have their LambdaFormInfo set to -reflect the fact that they are evaluated . This is necessary as otherwise +reflect the fact that they are evaluated. This is necessary as otherwise references to them may be passed untagged to code that expects tagged -references. +references because of the unlifted nature of the argument. + +For example, in + + type T :: UnliftedType + data T = T1 + | T2 + + f :: T -> Int + f x = case x of T1 -> 1; T2 -> 2 + +`f` expects `x` to be evaluated and properly tagged due to its unliftedness. +We can guarantee all occurrences of `T1` and `T2` are considered evaluated and +are properly tagged by giving them the `LFCon` LambdaFormInfo which indicates +they are fully saturated constructor applications. +(The LambdaFormInfo is used to tag the pointer with the tag of the +constructor, in `litIdInfo`) What may be less obvious is that this must be done for not only datacon workers but also *wrappers*. The reason is found in this program @@ -109,11 +125,9 @@ pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage of the unlifted nature of its arguments by omitting handling of the zero tag when scrutinising them. -The fix is straightforward: extend the logic in `mkLFImported` to cover -(nullary) datacon wrappers as well as workers. This is safe because we -know that the wrapper of a nullary datacon will be in WHNF, even if it -includes equalities evidence (since such equalities are not runtime -relevant). This fixed #23146. +The fix is straightforward: ensure we always construct a /correct/ LFInfo for +datacon workers and wrappers, and populate the `lfInfo` with it. See +Note [LFInfo of DataCon workers and wrappers]. This fixed #23146. See also Note [The LFInfo of Imported Ids] -} ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -120,7 +120,8 @@ infixl 1 `setRuleInfo`, `setCafInfo`, `setDmdSigInfo`, `setCprSigInfo`, - `setDemandInfo` + `setDemandInfo`, + `setLFInfo` {- ************************************************************************ * * @@ -374,7 +375,12 @@ data IdInfo -- -- See documentation of the getters for what these packed fields mean. lfInfo :: !(Maybe LambdaFormInfo), - -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure + -- ^ If lfInfo = Just info, then the `info` is guaranteed /correct/. + -- If lfInfo = Nothing, then we do not have a `LambdaFormInfo` for this Id, + -- so (for imported Ids) we make a conservative version. + -- See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure + -- For locally-defined Ids other than DataCons, the `lfInfo` field is always Nothing. + -- See also Note [LFInfo of DataCon workers and wrappers] -- See documentation of the getters for what these packed fields mean. tagSig :: !(Maybe TagSig) ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -65,6 +65,7 @@ import GHC.Core.DataCon import GHC.Types.Literal import GHC.Types.SourceText +import GHC.Types.RepType ( countFunRepArgs ) import GHC.Types.Name.Set import GHC.Types.Name import GHC.Types.ForeignCall @@ -87,6 +88,10 @@ import GHC.Data.FastString import GHC.Data.List.SetOps import Data.List ( zipWith4 ) +-- A bit of a shame we must import these here +import GHC.StgToCmm.Types (LambdaFormInfo(..)) +import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown)) + {- ************************************************************************ * * @@ -595,11 +600,18 @@ mkDataConWorkId wkr_name data_con `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 + `setLFInfo` wkr_lf_info -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con + -- See Note [LFInfo of DataCon workers and wrappers] + wkr_lf_info + | wkr_arity == 0 = LFCon data_con + | otherwise = LFReEntrant TopLevel (countFunRepArgs wkr_arity wkr_ty) True ArgUnknown + -- LFInfo stores post-unarisation arity + ----------- Workers for newtypes -------------- univ_tvs = dataConUnivTyVars data_con ex_tcvs = dataConExTyCoVars data_con @@ -608,6 +620,7 @@ mkDataConWorkId wkr_name data_con `setArityInfo` 1 -- Arity 1 `setInlinePragInfo` dataConWrapperInlinePragma `setUnfoldingInfo` newtype_unf + `setLFInfo` (LFReEntrant TopLevel 1 True ArgUnknown) id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) res_ty_args = mkTyCoVarTys univ_tvs newtype_unf = assertPpr (null ex_tcvs && isSingleton arg_tys) @@ -618,6 +631,82 @@ mkDataConWorkId wkr_name data_con wrapNewTypeBody tycon res_ty_args (Var id_arg1) {- +Note [LFInfo of DataCon workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure, it's +crucial that saturated data con applications are given an LFInfo of `LFCon`. + +Since for data constructors we never serialise the worker and the wrapper (only +the data type declaration), we never serialise their lambda form info either. + +Therefore, when making data constructors workers and wrappers, we construct a +correct `LFInfo` for them right away, and put it it in the `lfInfo` field of the +worker/wrapper Id, ensuring that: + + The `lfInfo` field of a DataCon worker or wrapper is always populated with the correct LFInfo. + +How do we construct a /correct/ LFInfo for workers and wrappers? +(Remember: `LFCon` means "a saturated constructor application") + +(1) Data constructor workers and wrappers with arity > 0 are unambiguously +functions and should be given `LFReEntrant`, regardless of the runtime +relevance of the arguments. + - For example, `Just :: a -> Maybe a` is given `LFReEntrant`, + and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too. + +(2) A datacon /worker/ with zero arity is trivially fully saturated -- it takes +no arguments whatsoever (not even zero-width args), so it is given `LFCon`. + +(3) Perhaps surprisingly, a datacon /wrapper/ can be an `LFCon`. See Wrinkle (W1) below. +A datacon /wrapper/ with zero arity must be a fully saturated application of +the worker to zero-width arguments only (which are dropped after unarisation), +and therefore is also given `LFCon`. + +For example, consider the following data constructors: + + data T1 a where + TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a + + data T2 a where + TCon2 :: {-# UNPACK #-} !() -> T2 a + + data T3 a where + TCon3 :: T3 '[] + +`TCon1`'s wrapper has a lifted argument, which is non-zero-width, while the +worker has an unlifted equality argument, which is zero-width. + +`TCon2`'s wrapper has a lifted argument, which is non-zero-width, while the +worker has no arguments. + +Wrinkle (W1). Perhaps surprisingly, it is possible for the /wrapper/ to be an +`LFCon` even though the /worker/ is not. Consider `T3` above. Here is the +Core representation of the worker and wrapper: + + $WTCon3 :: T3 '[] -- Wrapper + $WTCon3 = TCon3 @[] -- A saturated constructor application: LFCon + + TCon3 :: forall (a :: * -> *). (a ~# []) => T a -- Worker + TCon3 = /\a. \(co :: a~#[]). TCon3 co -- A function: LFReEntrant + +For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they +both have arity == 1. + +For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 +while the worker is `LFCon` since its arity == 0 + +For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the +worker `LFReEntrant` since its arity == 1 + +One might think we could give *workers* with only zero-width-args the `LFCon` +LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. +However, these workers are unambiguously functions +-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. +See also the discussion in #23158. + +See also the Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] +in GHC.StgToCmm.Types. + ------------------------------------------------- -- Data constructor representation -- @@ -709,11 +798,18 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane + `setLFInfo` wrap_lf_info -- The signature is purely for passes like the Simplifier, not for -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers]. wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv + -- See Note [LFInfo of DataCon workers and wrappers] + wrap_lf_info + | wrap_arity == 0 = LFCon data_con + | otherwise = LFReEntrant TopLevel (countFunRepArgs wrap_arity wrap_ty) True ArgUnknown + -- LFInfo stores post-unarisation arity + wrap_arg_dmds = replicate (length theta) topDmd ++ map mk_dmd arg_ibangs -- Don't forget the dictionary arguments when building ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -84,12 +84,11 @@ isNvUnaryType ty = False -- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep] +typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep typePrimRepArgs ty - | [] <- reps - = [VoidRep] - | otherwise - = reps + = case reps of + [] -> VoidRep :| [] + (x:xs) -> x :| xs where reps = typePrimRep ty @@ -124,6 +123,10 @@ unwrapType ty | otherwise = NS_Done +-- | Count the arity of a function post-unarisation, including zero-width arguments. +-- +-- The post-unarisation arity may be larger than the arity of the original +-- function type. See Note [Unarisation]. countFunRepArgs :: Arity -> Type -> RepArity countFunRepArgs 0 _ = 0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/94db08351659f012361c44ff1e9d5224f1407f06...f801b269a9475f86cc003a431b1045f3cf0db897 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/94db08351659f012361c44ff1e9d5224f1407f06...f801b269a9475f86cc003a431b1045f3cf0db897 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 14:35:01 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Fri, 05 May 2023 10:35:01 -0400 Subject: [Git][ghc/ghc][wip/T23146] Merge outdated Note [Data con representation] into Note [Data constructor representation] Message-ID: <64551415be451_e3e0622b3d29839777@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: 0ccbf4a0 by Rodrigo Mesquita at 2023-05-05T15:34:52+01:00 Merge outdated Note [Data con representation] into Note [Data constructor representation] Introduce new Note [Constructor applications in STG] to better support the merge, and reference it from the relevant bits in the STG syntax. - - - - - 2 changed files: - compiler/GHC/Core/DataCon.hs - compiler/GHC/Stg/Syntax.hs Changes: ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -141,7 +141,19 @@ becomes case e of { T a' b -> let a = I# a' in ... } To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. +differently, as follows in Note [Data Constructor Naming]. + +The `dcRepType` field of a `DataCon` contains the type of the representation of +the constructor /worker/, also called the Core representation. + +The Core representation may differ from the type of the constructor /wrapper/ +(built by `mkDataConId`). Besides unpacking (as seen in the example above), +dictionaries and coercions become explict arguments in the Core representation +of a constructor. + +Note that this representation is still *different* from runtime +representation. (Which is what STG uses after unarise). +See Note [Constructor applications in STG] in GHC.Stg.Syntax. Note [Data Constructor Naming] @@ -528,7 +540,7 @@ data DataCon -- forall a x y. (a~(x,y), x~y, Ord x) => -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) + -- see Note [Data constructor representation]) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: -- case (e :: T t) of @@ -985,51 +997,6 @@ we consult HsImplBang: The boolean flag is used only for this warning. See #11270 for motivation. -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -So whenever this module talks about the representation of a data constructor -what it means is the DataCon with all Unpacking having been applied. -We can think of this as the Core representation. - -Here's an example illustrating the Core representation: - data Ord a => T a = MkT Int! a Void# -Here - T :: Ord a => Int -> a -> Void# -> T a -but the rep type is - Trep :: Int# -> a -> Void# -> T a -Actually, the unboxed part isn't implemented yet! - -Note that this representation is still *different* from runtime -representation. (Which is what STG uses after unarise). - -This is how T would end up being used in STG post-unarise: - - let x = T 1# y - in ... - case x of - T int a -> ... - -The Void# argument is dropped and the boxed int is replaced by an unboxed -one. In essence we only generate binders for runtime relevant values. - -We also flatten out unboxed tuples in this process. See the unarise -pass for details on how this is done. But as an example consider -`data S = MkS Bool (# Bool | Char #)` which when matched on would -result in an alternative with three binders like this - - MkS bool tag tpl_field -> - -See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] -for the details of this transformation. - ************************************************************************ * * ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -237,6 +237,50 @@ StgConApp and StgPrimApp --- saturated applications There are specialised forms of application, for constructors, primitives, and literals. + +Note [Constructor applications in STG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In STG, constructor applications `StgConApp` and `StgRhsCon` are always /fully saturated/. +However, the number of arguments saturating the application may differ +post-unarisation because we drop void arguments from `StgConApp` and `StgRhsCon` +constructor applications during unarisation. + +Therefore, in `StgConApp` and `StgRhsCon`: +* Before unarisation, we have the saturated list of the arguments [StgArg] +* Post unarisation, we have the saturated list of non-void arguments, the type +of which should really be [NonVoid StgArg] + +As an example, consider: + + data T a = MkT Int! a Void# + +The wrapper's representation and the worker's representation (i.e. the +datacon's Core representation) are respectively: + + $WT :: Int -> a -> Void# -> T a + T :: Int# -> a -> Void# -> T a + +T would end up being used in STG post-unarise as: + + let x = T 1# y + in ... + case x of + T int a -> ... + +The Void# argument is dropped. In essence we only generate binders for runtime +relevant values. + +We also flatten out unboxed tuples in this process. See the unarise +pass for details on how this is done. But as an example consider +`data S = MkS Bool (# Bool | Char #)` which when matched on would +result in an alternative with three binders like this + + MkS bool tag tpl_field -> + +See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] +for the details of this transformation. + -} | StgLit Literal @@ -245,7 +289,7 @@ literals. -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) + [StgArg] -- Saturated. See Note [Constructor applications in STG] [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call @@ -421,7 +465,7 @@ important): -- are not allocated. ConstructorNumber [StgTickish] - [StgArg] -- Args + [StgArg] -- Saturated Args. See Note [Constructor applications in STG] -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ccbf4a018b7819d04445bfd8e4406c3413d9f71 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ccbf4a018b7819d04445bfd8e4406c3413d9f71 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 14:44:03 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 05 May 2023 10:44:03 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/clean17 Message-ID: <645516337a063_e3e0627cadfb040762a@gitlab.mail> Matthew Pickering pushed new branch wip/clean17 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/clean17 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 14:54:18 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Fri, 05 May 2023 10:54:18 -0400 Subject: [Git][ghc/ghc][wip/T23146] 180 commits: Allow WARNING pragmas to be controlled with custom categories Message-ID: <6455189ae5dc5_e3e062d23d3f44179f3@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: f932c589 by Adam Gundry at 2023-03-24T02:36:09-04:00 Allow WARNING pragmas to be controlled with custom categories Closes #17209. This implements GHC Proposal 541, allowing a WARNING pragma to be annotated with a category like so: {-# WARNING in "x-partial" head "This function is undefined on empty lists." #-} The user can then enable, disable and set the severity of such warnings using command-line flags `-Wx-partial`, `-Werror=x-partial` and so on. There is a new warning group `-Wextended-warnings` containing all these warnings. Warnings without a category are treated as if the category was `deprecations`, and are (still) controlled by the flags `-Wdeprecations` and `-Wwarnings-deprecations`. Updates Haddock submodule. - - - - - 0426515b by Adam Gundry at 2023-03-24T02:36:09-04:00 Move mention of warning groups change to 9.8.1 release notes - - - - - b8d783d2 by Ben Gamari at 2023-03-24T02:36:45-04:00 nativeGen/AArch64: Fix bitmask immediate predicate Previously the predicate for determining whether a logical instruction operand could be encoded as a bitmask immediate was far too conservative. This meant that, e.g., pointer untagged required five instructions whereas it should only require one. Fixes #23030. - - - - - 46120bb6 by Joachim Breitner at 2023-03-24T13:09:43-04:00 User's guide: Improve docs for -Wall previously it would list the warnings _not_ enabled by -Wall. That’s unnecessary round-about and was out of date. So let's just name the relevant warnings (based on `compiler/GHC/Driver/Flags.hs`). - - - - - 509d1f11 by Ben Gamari at 2023-03-24T13:10:20-04:00 codeGen/tsan: Disable instrumentation of unaligned stores There is some disagreement regarding the prototype of `__tsan_unaligned_write` (specifically whether it takes just the written address, or the address and the value as an argument). Moreover, I have observed crashes which appear to be due to it. Disable instrumentation of unaligned stores as a temporary mitigation. Fixes #23096. - - - - - 6a73655f by Li-yao Xia at 2023-03-25T00:02:44-04:00 base: Document GHC versions associated with past base versions in the changelog - - - - - 43bd7694 by Teo Camarasu at 2023-03-25T00:03:24-04:00 Add regression test for #17574 This test currently fails in the nonmoving way - - - - - f2d56bf7 by Teo Camarasu at 2023-03-25T00:03:24-04:00 fix: account for large and compact object stats with nonmoving gc Make sure that we keep track of the size of large and compact objects that have been moved onto the nonmoving heap. We keep track of their size and add it to the amount of live bytes in nonmoving segments to get the total size of the live nonmoving heap. Resolves #17574 - - - - - 7131b705 by David Feuer at 2023-03-25T00:04:04-04:00 Modify ThreadId documentation and comments For a long time, `GHC.Conc.Sync` has said ```haskell -- ToDo: data ThreadId = ThreadId (Weak ThreadId#) -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. ``` We are now actually capable of using `Weak# ThreadId#`, but the world has moved on. To support the `Show` and `Ord` instances, we'd need to store the thread ID number in the `ThreadId`. And it seems very difficult to continue to support `threadStatus` in that regime, since it needs to be able to explain how threads died. In addition, garbage collection of weak references can be quite expensive, and it would be hard to evaluate the cost over he whole ecosystem. As discussed in [this CLC issue](https://github.com/haskell/core-libraries-committee/issues/125), it doesn't seem very likely that we'll actually switch to weak references here. - - - - - c421bbbb by Ben Gamari at 2023-03-25T00:04:41-04:00 rts: Fix barriers of IND and IND_STATIC Previously IND and IND_STATIC lacked the acquire barriers enjoyed by BLACKHOLE. As noted in the (now updated) Note [Heap memory barriers], this barrier is critical to ensure that the indirectee is visible to the entering core. Fixes #22872. - - - - - 62fa7faa by Bodigrim at 2023-03-25T00:05:22-04:00 Improve documentation of atomicModifyMutVar2# - - - - - b2d14d0b by Cheng Shao at 2023-03-25T03:46:43-04:00 rts: use performBlockingMajorGC in hs_perform_gc and fix ffi023 This patch does a few things: - Add the missing RtsSymbols.c entry of performBlockingMajorGC - Make hs_perform_gc call performBlockingMajorGC, which restores previous behavior - Use hs_perform_gc in ffi023 - Remove rts_clearMemory() call in ffi023, it now works again in some test ways previously marked as broken. Fixes #23089 - - - - - d9ae24ad by Cheng Shao at 2023-03-25T03:46:44-04:00 testsuite: add the rts_clearMemory test case This patch adds a standalone test case for rts_clearMemory that mimics how it's typically used by wasm backend users and ensures this RTS API isn't broken by future RTS refactorings. Fixes #23901. - - - - - 80729d96 by Bodigrim at 2023-03-25T03:47:22-04:00 Improve documentation for resizing of byte arrays - - - - - c6ec4cd1 by Ben Gamari at 2023-03-25T20:23:47-04:00 rts: Don't rely on EXTERN_INLINE for slop-zeroing logic Previously we relied on calling EXTERN_INLINE functions defined in ClosureMacros.h from Cmm to zero slop. However, as far as I can tell, this is no longer safe to do in C99 as EXTERN_INLINE definitions may be emitted in each compilation unit. Fix this by explicitly declaring a new set of non-inline functions in ZeroSlop.c which can be called from Cmm and marking the ClosureMacros.h definitions as INLINE_HEADER. In the future we should try to eliminate EXTERN_INLINE. - - - - - c32abd4b by Ben Gamari at 2023-03-25T20:23:48-04:00 rts: Fix capability-count check in zeroSlop Previously `zeroSlop` examined `RtsFlags` to determine whether the program was single-threaded. This is wrong; a program may be started with `+RTS -N1` yet the process may later increase the capability count with `setNumCapabilities`. This lead to quite subtle and rare crashes. Fixes #23088. - - - - - 656d4cb3 by Ryan Scott at 2023-03-25T20:24:23-04:00 Add Eq/Ord instances for SSymbol, SChar, and SNat This implements [CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148). - - - - - 4f93de88 by David Feuer at 2023-03-26T15:33:02-04:00 Update and expand atomic modification Haddocks * The documentation for `atomicModifyIORef` and `atomicModifyIORef'` were incomplete, and the documentation for `atomicModifyIORef` was out of date. Update and expand. * Remove a useless lazy pattern match in the definition of `atomicModifyIORef`. The pair it claims to match lazily was already forced by `atomicModifyIORef2`. - - - - - e1fb56b2 by David Feuer at 2023-03-26T15:33:41-04:00 Document the constructor name for lists Derived `Data` instances use raw infix constructor names when applicable. The `Data.Data [a]` instance, if derived, would have a constructor name of `":"`. However, it actually uses constructor name `"(:)"`. Document this peculiarity. See https://github.com/haskell/core-libraries-committee/issues/147 - - - - - c1f755c4 by Simon Peyton Jones at 2023-03-27T22:09:41+01:00 Make exprIsConApp_maybe a bit cleverer Addresses #23159. See Note Note [Exploit occ-info in exprIsConApp_maybe] in GHC.Core.SimpleOpt. Compile times go down very slightly, but always go down, never up. Good! Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -1.8% T15703(normal) -1.2% GOOD geo. mean -0.1% minimum -1.8% maximum +0.0% Metric Decrease: CoOpt_Singletons T15703 - - - - - 76bb4c58 by Ryan Scott at 2023-03-28T08:12:08-04:00 Add COMPLETE pragmas to TypeRep, SSymbol, SChar, and SNat This implements [CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149). - - - - - 3f374399 by sheaf at 2023-03-29T13:57:33+02:00 Handle records in the renamer This patch moves the field-based logic for disambiguating record updates to the renamer. The type-directed logic, scheduled for removal, remains in the typechecker. To do this properly (and fix the myriad of bugs surrounding the treatment of duplicate record fields), we took the following main steps: 1. Create GREInfo, a renamer-level equivalent to TyThing which stores information pertinent to the renamer. This allows us to uniformly treat imported and local Names in the renamer, as described in Note [GREInfo]. 2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which distinguished between normal names and field names, we now store simple Names in GlobalRdrElt, along with the new GREInfo information which allows us to recover the FieldLabel for record fields. 3. Add namespacing for record fields, within the OccNames themselves. This allows us to remove the mangling of duplicate field selectors. This change ensures we don't print mangled names to the user in error messages, and allows us to handle duplicate record fields in Template Haskell. 4. Move record disambiguation to the renamer, and operate on the level of data constructors instead, to handle #21443. The error message text for ambiguous record updates has also been changed to reflect that type-directed disambiguation is on the way out. (3) means that OccEnv is now a bit more complex: we first key on the textual name, which gives an inner map keyed on NameSpace: OccEnv a ~ FastStringEnv (UniqFM NameSpace a) Note that this change, along with (2), both increase the memory residency of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to regress somewhat in compile-time allocation. Even though (3) simplified a lot of code (in particular the treatment of field selectors within Template Haskell and in error messages), it came with one important wrinkle: in the situation of -- M.hs-boot module M where { data A; foo :: A -> Int } -- M.hs module M where { data A = MkA { foo :: Int } } we have that M.hs-boot exports a variable foo, which is supposed to match with the record field foo that M exports. To solve this issue, we add a new impedance-matching binding to M foo{var} = foo{fld} This mimics the logic that existed already for impedance-binding DFunIds, but getting it right was a bit tricky. See Note [Record field impedance matching] in GHC.Tc.Module. We also needed to be careful to avoid introducing space leaks in GHCi. So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in ModIface. This means stubbing out all the GREInfo fields, with the function forceGlobalRdrEnv. When we read it back in, we rehydrate with rehydrateGlobalRdrEnv. This robustly avoids any space leaks caused by retaining old type environments. Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063 Updates haddock submodule ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiLayerModulesDefsGhci MultiLayerModulesNoCode T13701 T14697 hard_hole_fits ------------------------- - - - - - 4f1940f0 by sheaf at 2023-03-29T13:57:33+02:00 Avoid repeatedly shadowing in shadowNames This commit refactors GHC.Type.Name.Reader.shadowNames to first accumulate all the shadowing arising from the introduction of a new set of GREs, and then applies all the shadowing to the old GlobalRdrEnv in one go. - - - - - d246049c by sheaf at 2023-03-29T13:57:34+02:00 igre_prompt_env: discard "only-qualified" names We were unnecessarily carrying around names only available qualified in igre_prompt_env, violating the icReaderEnv invariant. We now get rid of these, as they aren't needed for the shadowing computation that igre_prompt_env exists for. Fixes #23177 ------------------------- Metric Decrease: T14052 T14052Type ------------------------- - - - - - 41a572f6 by Matthew Pickering at 2023-03-29T16:17:21-04:00 hadrian: Fix path to HpcParser.y The source for this project has been moved into a src/ folder so we also need to update this path. Fixes #23187 - - - - - b159e0e9 by doyougnu at 2023-03-30T01:40:08-04:00 js: split JMacro into JS eDSL and JS syntax This commit: Splits JExpr and JStat into two nearly identical DSLs: - GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a value cannot be unsaturated, or, a value of this DSL is a witness that a value of GHC.JS.Unsat has been saturated - GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation. Then all binary and outputable instances are changed to use GHC.JS.Syntax. This moves us closer to closing out #22736 and #22352. See #22736 for roadmap. ------------------------- Metric Increase: CoOpt_Read LargeRecord ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T10858 T11195 T11374 T11822 T12227 T12707 T13035 T13253 T13253-spj T13379 T14683 T15164 T15703 T16577 T17096 T17516 T17836 T18140 T18282 T18304 T18478 T18698a T18698b T18923 T1969 T19695 T20049 T21839c T3064 T4801 T5321FD T5321Fun T5631 T5642 T783 T9198 T9233 T9630 TcPlugin_RewritePerf WWRec ------------------------- - - - - - f4f1f14f by Sylvain Henry at 2023-03-30T01:40:49-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. Also used the opportunity to reenable 64-bit Word/Int tests - - - - - a5360490 by Ben Gamari at 2023-03-30T01:41:25-04:00 testsuite: Fix racing prints in T21465 As noted in #23155, we previously failed to add flushes necessary to ensure predictable output. Fixes #23155. - - - - - 98b5cf67 by Matthew Pickering at 2023-03-30T09:58:40+01:00 Revert "ghc-heap: remove wrong Addr# coercion (#23181)" This reverts commit f4f1f14f8009c3c120b8b963ec130cbbc774ec02. This fails to build with GHC-9.2 as a boot compiler. See #23195 for tracking this issue. - - - - - 61a2dfaa by Bodigrim at 2023-03-30T14:35:57-04:00 Add {-# WARNING #-} to Data.List.{head,tail} - - - - - 8f15c47c by Bodigrim at 2023-03-30T14:35:57-04:00 Fixes to accomodate Data.List.{head,tail} with {-# WARNING #-} - - - - - 7c7dbade by Bodigrim at 2023-03-30T14:35:57-04:00 Bump submodules - - - - - d2d8251b by Bodigrim at 2023-03-30T14:35:57-04:00 Fix tests - - - - - 3d38dcb6 by sheaf at 2023-03-30T14:35:57-04:00 Proxies for head and tail: review suggestions - - - - - 930edcfd by sheaf at 2023-03-30T14:36:33-04:00 docs: move RecordUpd changelog entry to 9.8 This was accidentally included in the 9.6 changelog instead of the 9.6 changelog. - - - - - 6f885e65 by sheaf at 2023-03-30T14:37:09-04:00 Add LANGUAGE GADTs to GHC.Rename.Env We need to enable this extension for the file to compile with ghc 9.2, as we are pattern matching on a GADT and this required the GADT extension to be enabled until 9.4. - - - - - 6d6a37a8 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: make lint-ci-config job fast again We don't pin our nixpkgs revision and tracks the default nixpkgs-unstable channel anyway. Instead of using haskell.packages.ghc924, we should be using haskell.packages.ghc92 to maximize the binary cache hit rate and make lint-ci-config job fast again. Also bumps the nix docker image to the latest revision. - - - - - ef1548c4 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: ensure that all non-i386 pipelines do parallel xz compression We can safely enable parallel xz compression for non-i386 pipelines. However, previously we didn't export XZ_OPT, so the xz process won't see it if XZ_OPT hasn't already been set in the current job. - - - - - 20432d16 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: unset CROSS_EMULATOR for js job - - - - - 4a24dbbe by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: fix lint-testsuite job The list_broken make target will transitively depend on the calibrate.out target, which used STAGE1_GHC instead of TEST_HC. It really should be TEST_HC since that's what get passed in the gitlab CI config. - - - - - cea56ccc by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: use alpine3_17-wasm image for wasm jobs Bump the ci-images dependency and use the new alpine3_17-wasm docker image for wasm jobs. - - - - - 79d0cb32 by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - e7392b4e by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Normalize away differences in ghc executable name - - - - - ee160d06 by Ben Gamari at 2023-03-30T18:43:53+00:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - 30c84511 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: don't add optllvm way for wasm32 - - - - - f1beee36 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: normalize the .wasm extension - - - - - a984a103 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: strip the cross ghc prefix in output and error message - - - - - f7478d95 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: handle target executable extension - - - - - 8fe8b653 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: mypy typing error fixes This patch fixes some mypy typing errors which weren't caught in previous linting jobs. - - - - - 0149f32f by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: use context variable instead of thread-local variable This patch changes a thread-local variable to context variable instead, which works as intended when the testsuite transitions to use asyncio & coroutines instead of multi-threading to concurrently run test cases. Note that this also raises the minimum Python version to 3.7. - - - - - ea853ff0 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: asyncify the testsuite driver This patch refactors the testsuite driver, gets rid of multi-threading logic for running test cases concurrently, and uses asyncio & coroutines instead. This is not yak shaving for its own sake; the previous multi-threading logic is prone to livelock/deadlock conditions for some reason, even if the total number of threads is bounded to a thread pool's capacity. The asyncify change is an internal implementation detail of the testsuite driver and does not impact most GHC maintainers out there. The patch does not touch the .T files, test cases can be added/modified the exact same way as before. - - - - - 0077cb22 by Matthew Pickering at 2023-03-31T21:28:28-04:00 Add test for T23184 There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj at microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 A bunch of changes related to eta reduction This is a large collection of changes all relating to eta reduction, originally triggered by #18993, but there followed a long saga. Specifics: ...lots of lines omitted... Other incidental changes * Fix a fairly long-standing outright bug in the ApplyToVal case of GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the tail of 'dmds' in the recursive call, which meant the demands were All Wrong. I have no idea why this has not caused problems before now. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes. - - - - - 62d25071 by mangoiv at 2023-04-01T04:20:01-04:00 [feat] make ($) representation polymorphic - this change was approved by the CLC in [1] following a CLC proposal [2] - make ($) representation polymorphic (adjust the type signature) - change ($) implementation to allow additional polymorphism - adjust the haddock of ($) to reflect these changes - add additional documentation to document these changes - add changelog entry - adjust tests (move now succeeding tests and adjust stdout of some tests) [1] https://github.com/haskell/core-libraries-committee/issues/132#issuecomment-1487456854 [2] https://github.com/haskell/core-libraries-committee/issues/132 - - - - - 77c33fb9 by Artem Pelenitsyn at 2023-04-01T04:20:41-04:00 User Guide: update copyright year: 2020->2023 - - - - - 3b5be05a by doyougnu at 2023-04-01T09:42:31-04:00 driver: Unit State Data.Map -> GHC.Unique.UniqMap In pursuit of #22426. The driver and unit state are major contributors. This commit also bumps the haddock submodule to reflect the API changes in UniqMap. ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp T10421 T10547 T12150 T12234 T12425 T13035 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T5837 T6048 T9198 ------------------------- - - - - - a84fba6e by Torsten Schmits at 2023-04-01T09:43:12-04:00 Add structured error messages for GHC.Tc.TyCl Tracking ticket: #20117 MR: !10183 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 6e2eb275 by doyougnu at 2023-04-01T18:27:56-04:00 JS: Linker: use saturated JExpr Follow on to MR!10142 in pursuit of #22736 - - - - - 3da69346 by sheaf at 2023-04-01T18:28:37-04:00 Improve haddocks of template-haskell Con datatype This adds a bit more information, in particular about the lists of constructors in the GadtC and RecGadtC cases. - - - - - 3b7bbb39 by sheaf at 2023-04-01T18:28:37-04:00 TH: revert changes to GadtC & RecGadtC Commit 3f374399 included a breaking-change to the template-haskell library when it made the GadtC and RecGadtC constructors take non-empty lists of names. As this has the potential to break many users' packages, we decided to revert these changes for now. - - - - - f60f6110 by Bodigrim at 2023-04-02T18:59:30-04:00 Rework documentation for data Char - - - - - 43ebd5dc by Bodigrim at 2023-04-02T19:00:09-04:00 cmm: implement parsing of MO_AtomicRMW from hand-written CMM files Fixes #23206 - - - - - ab9cd52d by Sylvain Henry at 2023-04-03T08:15:21-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. - - - - - 2b2afff3 by Matthew Pickering at 2023-04-03T08:15:58-04:00 hadrian: Update bootstrap plans for 9.2.6, 9.2.7, 9.4.4, 9.4.5, 9.6.1 Also fixes the ./generate_bootstrap_plans script which was recently broken We can hopefully drop the 9.2 plans soon but they still work so kept them around for now. - - - - - c2605e25 by Matthew Pickering at 2023-04-03T08:15:58-04:00 ci: Add job to test 9.6 bootstrapping - - - - - 53e4d513 by Krzysztof Gogolewski at 2023-04-03T08:16:35-04:00 hadrian: Improve option parsing Several options in Hadrian had their argument marked as optional (`OptArg`), but if the argument wasn't there they were just giving an error. It's more idiomatic to mark the argument as required instead; the code uses less Maybes, the parser can enforce that the argument is present, --help gives better output. - - - - - a8e36892 by Sylvain Henry at 2023-04-03T08:17:16-04:00 JS: fix issues with FD api support - Add missing implementations for fcntl_read/write/lock - Fix fdGetMode These were found while implementing TH in !9779. These functions must be used somehow by the external interpreter code. - - - - - 8b092910 by Haskell-mouse at 2023-04-03T19:31:26-04:00 Convert diagnostics in GHC.Rename.HsType to proper TcRnMessage I've turned all occurrences of TcRnUnknownMessage in GHC.Rename.HsType module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnDataKindsError TcRnUnusedQuantifiedTypeVar TcRnIllegalKindSignature TcRnUnexpectedPatSigType TcRnSectionPrecedenceError TcRnPrecedenceParsingError TcRnIllegalKind TcRnNegativeNumTypeLiteral TcRnUnexpectedKindVar TcRnBindMultipleVariables TcRnBindVarAlreadyInScope - - - - - 220a7a48 by Krzysztof Gogolewski at 2023-04-03T19:32:02-04:00 Fixes around unsafeCoerce# 1. `unsafeCoerce#` was documented in `GHC.Prim`. But since the overhaul in 74ad75e87317, `unsafeCoerce#` is no longer defined there. I've combined the documentation in `GHC.Prim` with the `Unsafe.Coerce` module. 2. The documentation of `unsafeCoerce#` stated that you should not cast a function to an algebraic type, even if you later cast it back before applying it. But ghci was doing that type of cast, as can be seen with 'ghci -ddump-ds' and typing 'x = not'. I've changed it to use Any following the documentation. - - - - - 9095e297 by Matthew Craven at 2023-04-04T01:04:10-04:00 Add a few more memcpy-ish primops * copyMutableByteArrayNonOverlapping# * copyAddrToAddr# * copyAddrToAddrNonOverlapping# * setAddrRange# The implementations of copyBytes, moveBytes, and fillBytes in base:Foreign.Marshal.Utils now use these new primops, which can cause us to work a bit harder generating code for them, resulting in the metric increase in T21839c observed by CI on some architectures. But in exchange, we get better code! Metric Increase: T21839c - - - - - f7da530c by Matthew Craven at 2023-04-04T01:04:10-04:00 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. - - - - - cd00e321 by sheaf at 2023-04-04T01:04:50-04:00 Relax assertion in varToRecFieldOcc When using Template Haskell, it is possible to re-parent a field OccName belonging to one data constructor to another data constructor. The lsp-types package did this in order to "extend" a data constructor with additional fields. This ran into an assertion in 'varToRecFieldOcc'. This assertion can simply be relaxed, as the resulting splices are perfectly sound. Fixes #23220 - - - - - eed0d930 by Sylvain Henry at 2023-04-04T11:09:15-04:00 GHCi.RemoteTypes: fix doc and avoid unsafeCoerce (#23201) - - - - - 071139c3 by Ryan Scott at 2023-04-04T11:09:51-04:00 Make INLINE pragmas for pattern synonyms work with TH Previously, the code for converting `INLINE <name>` pragmas from TH splices used `vNameN`, which assumed that `<name>` must live in the variable namespace. Pattern synonyms, on the other hand, live in the constructor namespace. I've fixed the issue by switching to `vcNameN` instead, which works for both the variable and constructor namespaces. Fixes #23203. - - - - - 7c16f3be by Krzysztof Gogolewski at 2023-04-04T17:13:00-04:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). - - - - - c165f079 by sheaf at 2023-04-04T17:13:40-04:00 Add testcase for #23192 This issue around solving of constraints arising from superclass expansion using other constraints also borned from superclass expansion was the topic of commit aed1974e. That commit made sure we don't emit a "redundant constraint" warning in a situation in which removing the constraint would cause errors. Fixes #23192 - - - - - d1bb16ed by Ben Gamari at 2023-04-06T03:40:45-04:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 - - - - - 04b80850 by Brandon Chinn at 2023-04-06T03:41:21-04:00 Fix reverse flag for -Wunsupported-llvm-version - - - - - 0c990e13 by Pierre Le Marre at 2023-04-06T10:16:29+00:00 Add release note for GHC.Unicode refactor in base-4.18. Also merge CLC proposal 130 in base-4.19 with CLC proposal 59 in base-4.18 and add proper release date. - - - - - cbbfb283 by Alex Dixon at 2023-04-07T18:27:45-04:00 Improve documentation for ($) (#22963) - - - - - 5193c2b0 by Alex Dixon at 2023-04-07T18:27:45-04:00 Remove trailing whitespace from ($) commentary - - - - - b384523b by Sebastian Graf at 2023-04-07T18:27:45-04:00 Adjust wording wrt representation polymorphism of ($) - - - - - 6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00 Add structured error messages for GHC.Tc.TyCl.Utils Tracking ticket: #20117 MR: !10251 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00 Renamer: don't call addUsedGRE on an exact Name When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc, we could end up calling addUsedGRE on an exact Name, which would then lead to a panic in the bestImport function: it would be incapable of processing a GRE which is not local but also not brought into scope by any imports (as it is referred to by its unique instead). Fixes #23240 - - - - - bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00 Set base 'maintainer' field to CLC - - - - - ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00 Clarify a couple of Notes about 'nospec' - - - - - ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - f382f304 by Ben Gamari at 2023-05-05T15:53:19+01:00 testsuite: Add tests for #23146 Both lifted and unlifted variants. - - - - - 50f47437 by Ben Gamari at 2023-05-05T15:53:19+01:00 codeGen: Fix some Haddocks - - - - - 69d3fd21 by Ben Gamari at 2023-05-05T15:53:19+01:00 codeGen: Give proper LFInfo to datacon wrappers As noted in `Note [Conveying CAF-info and LFInfo between modules]`, when importing a binding from another module we must ensure that it gets the appropriate `LambdaFormInfo` if it is in WHNF to ensure that references to it are tagged correctly. However, the implementation responsible for doing this, `GHC.StgToCmm.Closure.mkLFImported`, only dealt with datacon workers and not wrappers. This lead to the crash of this program in #23146: module B where type NP :: [UnliftedType] -> UnliftedType data NP xs where UNil :: NP '[] module A where import B fieldsSam :: NP xs -> NP xs -> Bool fieldsSam UNil UNil = True x = fieldsSam UNil UNil Due to its GADT nature, `UNil` produces a trivial wrapper $WUNil :: NP '[] $WUNil = UNil @'[] @~(<co:1>) which is referenced in the RHS of `A.x`. Due to the above-mentioned bug in `mkLFImported`, the references to `$WUNil` passed to `fieldsSam` were not tagged. This is problematic as `fieldsSam` expected its arguments to be tagged as they are unlifted. The fix is straightforward: extend the logic in `mkLFImported` to cover (nullary) datacon wrappers as well as workers. This is safe because we know that the wrapper of a nullary datacon will be in WHNF, even if it includes equalities evidence (since such equalities are not runtime relevant). Thanks to @MangoIV for the great ticket and @alt-romes for his minimization and help debugging. Fixes #23146. - - - - - 900942b1 by Rodrigo Mesquita at 2023-05-05T15:53:19+01:00 codeGen: Fix LFInfo of imported datacon wrappers As noted in #23231 and in the previous commit, we were failing to give a an LFInfo of LFCon to a nullary datacon wrapper from another module, failing to properly tag pointers which ultimately led to the segmentation fault in #23146. On top of the previous commit which now considers wrappers where we previously only considered workers, we change the order of the guards so that we check for the arity of the binding before we check whether it is a constructor. This allows us to (1) Correctly assign `LFReEntrant` to imported wrappers whose worker was nullary, which we previously would fail to do (2) Remove the `isNullaryRepDataCon` predicate: (a) which was previously wrong, since it considered wrappers whose workers had zero-width arguments to be non-nullary and would fail to give `LFCon` to them (b) is now unnecessary, since arity == 0 guarantees - that the worker takes no arguments at all - and the wrapper takes no arguments and its RHS must be an application of the worker to zero-width-args only. - we lint these two items with an assertion that the datacon `hasNoNonZeroWidthArgs` We also update `isTagged` to use the new logic in determining the LFInfos of imported Ids. The creation of LFInfos for imported Ids and this detail are explained in Note [The LFInfo of Imported Ids]. Note that before the patch to those issues we would already consider these nullary wrappers to have `LFCon` lambda form info; but failed to re-construct that information in `mkLFImported` Closes #23231, #23146 (I've additionally batched some fixes to documentation I found while investigating this issue) - - - - - 641aaa5c by Rodrigo Mesquita at 2023-05-05T15:53:19+01:00 Make LFInfos for DataCons on construction As a result of the discussion in !10165, we decided to amend the previous commit which fixed the logic of `mkLFImported` with regard to datacon workers and wrappers. Instead of having the logic for the LFInfo of datacons be in `mkLFImported`, we now construct an LFInfo for all data constructors on GHC.Types.Id.Make and store it in the `lfInfo` field. See the new Note [LFInfo of DataCon workers and wrappers] and ammendments to Note [The LFInfo of Imported Ids] - - - - - dc5132f2 by Rodrigo Mesquita at 2023-05-05T15:53:19+01:00 Update Note [Core letrec invariant] Authored by @simonpj - - - - - e0784ad7 by Rodrigo Mesquita at 2023-05-05T15:53:19+01:00 Rename mkLFImported to importedIdLFInfo The `mkLFImported` sounded too much like a constructor of sorts, when really it got the `LFInfo` of an imported Id from its `lf_info` field when this existed, and otherwise returned a conservative estimate of that imported Id's LFInfo. This in contrast to functions such as `mkLFReEntrant` which really are about constructing an `LFInfo`. - - - - - a20ba1e4 by Rodrigo Mesquita at 2023-05-05T15:53:19+01:00 Enforce invariant on typePrimRepArgs in the types As part of the documentation effort in !10165 I came across this invariant on 'typePrimRepArgs' which is easily expressed at the type-level through a NonEmpty list. It allowed us to remove one panic. - - - - - cd033ac4 by Rodrigo Mesquita at 2023-05-05T15:54:02+01:00 Merge outdated Note [Data con representation] into Note [Data constructor representation] Introduce new Note [Constructor applications in STG] to better support the merge, and reference it from the relevant bits in the STG syntax. - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/generate_job_metadata - .gitlab/generate_jobs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - .gitmodules - cabal.project-reinstall - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/Wasm/Types.hs - compiler/GHC/CmmToAsm/Wasm/Utils.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0ccbf4a018b7819d04445bfd8e4406c3413d9f71...cd033ac4a775e295bbd860925767f896d81d0600 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0ccbf4a018b7819d04445bfd8e4406c3413d9f71...cd033ac4a775e295bbd860925767f896d81d0600 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 14:55:18 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Fri, 05 May 2023 10:55:18 -0400 Subject: [Git][ghc/ghc][wip/T23146] Merge outdated Note [Data con representation] into Note [Data constructor representation] Message-ID: <645518d68e12c_e3e0627131c04418763@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: c77f81c8 by Rodrigo Mesquita at 2023-05-05T15:55:10+01:00 Merge outdated Note [Data con representation] into Note [Data constructor representation] Introduce new Note [Constructor applications in STG] to better support the merge, and reference it from the relevant bits in the STG syntax. - - - - - 2 changed files: - compiler/GHC/Core/DataCon.hs - compiler/GHC/Stg/Syntax.hs Changes: ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -141,7 +141,19 @@ becomes case e of { T a' b -> let a = I# a' in ... } To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. +differently, as follows in Note [Data Constructor Naming]. + +The `dcRepType` field of a `DataCon` contains the type of the representation of +the constructor /worker/, also called the Core representation. + +The Core representation may differ from the type of the constructor /wrapper/ +(built by `mkDataConId`). Besides unpacking (as seen in the example above), +dictionaries and coercions become explict arguments in the Core representation +of a constructor. + +Note that this representation is still *different* from runtime +representation. (Which is what STG uses after unarise). +See Note [Constructor applications in STG] in GHC.Stg.Syntax. Note [Data Constructor Naming] @@ -528,7 +540,7 @@ data DataCon -- forall a x y. (a~(x,y), x~y, Ord x) => -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) + -- see Note [Data constructor representation]) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: -- case (e :: T t) of @@ -985,51 +997,6 @@ we consult HsImplBang: The boolean flag is used only for this warning. See #11270 for motivation. -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -So whenever this module talks about the representation of a data constructor -what it means is the DataCon with all Unpacking having been applied. -We can think of this as the Core representation. - -Here's an example illustrating the Core representation: - data Ord a => T a = MkT Int! a Void# -Here - T :: Ord a => Int -> a -> Void# -> T a -but the rep type is - Trep :: Int# -> a -> Void# -> T a -Actually, the unboxed part isn't implemented yet! - -Note that this representation is still *different* from runtime -representation. (Which is what STG uses after unarise). - -This is how T would end up being used in STG post-unarise: - - let x = T 1# y - in ... - case x of - T int a -> ... - -The Void# argument is dropped and the boxed int is replaced by an unboxed -one. In essence we only generate binders for runtime relevant values. - -We also flatten out unboxed tuples in this process. See the unarise -pass for details on how this is done. But as an example consider -`data S = MkS Bool (# Bool | Char #)` which when matched on would -result in an alternative with three binders like this - - MkS bool tag tpl_field -> - -See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] -for the details of this transformation. - ************************************************************************ * * ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -237,6 +237,52 @@ StgConApp and StgPrimApp --- saturated applications There are specialised forms of application, for constructors, primitives, and literals. + +Note [Constructor applications in STG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After the unarisation pass: +* In `StgConApp` and `StgRhsCon` and `StgAlt` we filter out the void arguments, + leaving only non-void ones. +* In `StgApp` and `StgOpApp` we retain void arguments. + +We can do this because we know that `StgConApp` and `StgRhsCon` are saturated applications, +so we lose no information by dropping those void args. In contrast, in `StgApp` we need the + void argument to compare the number of args in the call with the arity of the function. + +This is an open design choice. We could instead choose to treat all these applications +consistently (keeping the void args). But for some reason we don't, and this Note simply +documents that design choice. + +As an example, consider: + + data T a = MkT Int! a Void# + +The wrapper's representation and the worker's representation (i.e. the +datacon's Core representation) are respectively: + + $WT :: Int -> a -> Void# -> T a + T :: Int# -> a -> Void# -> T a + +T would end up being used in STG post-unarise as: + + let x = T 1# y + in ... + case x of + T int a -> ... + +The Void# argument is dropped. In essence we only generate binders for runtime +relevant values. + +We also flatten out unboxed tuples in this process. See the unarise +pass for details on how this is done. But as an example consider +`data S = MkS Bool (# Bool | Char #)` which when matched on would +result in an alternative with three binders like this + + MkS bool tag tpl_field -> + +See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] +for the details of this transformation. + -} | StgLit Literal @@ -245,7 +291,7 @@ literals. -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) + [StgArg] -- Saturated. See Note [Constructor applications in STG] [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call @@ -422,7 +468,7 @@ important): -- are not allocated. ConstructorNumber [StgTickish] - [StgArg] -- Args + [StgArg] -- Saturated Args. See Note [Constructor applications in STG] Type -- Type, for rewriting to an StgRhsClosure -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c77f81c87e43b1dd1d34d7c928b323b675cab8c5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c77f81c87e43b1dd1d34d7c928b323b675cab8c5 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 15:03:13 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 05 May 2023 11:03:13 -0400 Subject: [Git][ghc/ghc][wip/dynamic-alpine] Build vanilla alpine bindists Message-ID: <64551ab1ed4f5_e3e0627131c04428882@gitlab.mail> Matthew Pickering pushed to branch wip/dynamic-alpine at Glasgow Haskell Compiler / GHC Commits: 8fd803a4 by Matthew Pickering at 2023-05-05T16:03:01+01:00 Build vanilla alpine bindists We currently attempt to build and distribute fully static alpine bindists (ones which could be used on any linux platform) but most people who use the alpine bindists want to use alpine to build their own static applications (for which a fully static bindist is not necessary). We should build and distribute these bindists for these users whilst the fully-static bindist is still unusable. Fixes #23349 - - - - - 2 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml Changes: ===================================== .gitlab/gen_ci.hs ===================================== @@ -424,7 +424,7 @@ distroVariables Alpine = mconcat -- T10458, ghcilink002: due to #17869 -- linker_unload_native: due to musl not supporting any means of probing dynlib dependencies -- (see Note [Object unloading]). - , "BROKEN_TESTS" =: "encoding004 T10458 ghcilink002 linker_unload_native" + , "BROKEN_TESTS" =: "encoding004 T10458 linker_unload_native" ] distroVariables Centos7 = mconcat [ "HADRIAN_ARGS" =: "--docs=no-sphinx" @@ -903,8 +903,11 @@ job_groups = , standardBuildsWithConfig AArch64 (Linux Debian10) (splitSectionsBroken vanilla) , disableValidate (validateBuilds AArch64 (Linux Debian10) llvm) , standardBuildsWithConfig I386 (Linux Debian9) (splitSectionsBroken vanilla) - , standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken static) - , disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt)) + -- Fully static build, in theory usable on any linux distribution. + , fullyStaticBrokenTests (standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken static)) + -- Dynamically linked build, suitable for building your own static executables on alpine + , standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken vanilla) + , fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt))) , validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing) , validateBuilds Amd64 (Linux Debian11) (crossConfig "javascript-unknown-ghcjs" (Emulator "js-emulator") (Just "emconfigure") ) @@ -919,6 +922,10 @@ job_groups = ] where + + -- ghcilink002 broken due to #17869 + fullyStaticBrokenTests = modifyJobs (addVariable "BROKEN_TESTS" "ghcilink002 ") + hackage_doc_job = rename (<> "-hackage") . modifyJobs (addVariable "HADRIAN_ARGS" "--haddock-base-url") tsan_jobs = ===================================== .gitlab/jobs.yaml ===================================== @@ -597,7 +597,7 @@ "variables": { "BIGNUM_BACKEND": "native", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-int_native-validate+fully_static", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "validate+fully_static", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--docs=no-sphinx", @@ -606,6 +606,68 @@ "XZ_OPT": "-9" } }, + "nightly-x86_64-linux-alpine3_12-validate": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh clean", + "cat ci_timings" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "8 weeks", + "paths": [ + "ghc-x86_64-linux-alpine3_12-validate.tar.xz", + "junit.xml" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-alpine3_12-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate", + "BROKEN_TESTS": "encoding004 T10458 linker_unload_native", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--disable-ld-override ", + "HADRIAN_ARGS": "--docs=no-sphinx", + "INSTALL_CONFIGURE_ARGS": "--disable-ld-override", + "TEST_ENV": "x86_64-linux-alpine3_12-validate", + "XZ_OPT": "-9" + } + }, "nightly-x86_64-linux-alpine3_12-validate+fully_static": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -659,7 +721,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate+fully_static", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "validate+fully_static", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--docs=no-sphinx", @@ -2472,7 +2534,7 @@ "variables": { "BIGNUM_BACKEND": "native", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-int_native-release+fully_static", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "release+fully_static", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--hash-unit-ids --docs=no-sphinx", @@ -2535,7 +2597,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-release+fully_static+no_split_sections", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "release+fully_static+no_split_sections", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--hash-unit-ids --docs=no-sphinx", @@ -2545,6 +2607,69 @@ "XZ_OPT": "-9" } }, + "release-x86_64-linux-alpine3_12-release+no_split_sections": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh clean", + "cat ci_timings" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "1 year", + "paths": [ + "ghc-x86_64-linux-alpine3_12-release+no_split_sections.tar.xz", + "junit.xml" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-alpine3_12-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-release+no_split_sections", + "BROKEN_TESTS": "encoding004 T10458 linker_unload_native", + "BUILD_FLAVOUR": "release+no_split_sections", + "CONFIGURE_ARGS": "--disable-ld-override ", + "HADRIAN_ARGS": "--hash-unit-ids --docs=no-sphinx", + "IGNORE_PERF_FAILURES": "all", + "INSTALL_CONFIGURE_ARGS": "--disable-ld-override", + "TEST_ENV": "x86_64-linux-alpine3_12-release+no_split_sections", + "XZ_OPT": "-9" + } + }, "release-x86_64-linux-centos7-release+no_split_sections": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -3528,6 +3653,67 @@ "TEST_ENV": "x86_64-freebsd13-validate" } }, + "x86_64-linux-alpine3_12-validate": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh clean", + "cat ci_timings" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "2 weeks", + "paths": [ + "ghc-x86_64-linux-alpine3_12-validate.tar.xz", + "junit.xml" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-alpine3_12-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate", + "BROKEN_TESTS": "encoding004 T10458 linker_unload_native", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--disable-ld-override ", + "HADRIAN_ARGS": "--docs=no-sphinx", + "INSTALL_CONFIGURE_ARGS": "--disable-ld-override", + "TEST_ENV": "x86_64-linux-alpine3_12-validate" + } + }, "x86_64-linux-alpine3_12-validate+fully_static": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -3581,7 +3767,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate+fully_static", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "validate+fully_static", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--docs=no-sphinx", View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fd803a4fdbab1f8512e6bc935eb8d8e79ccfb0e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fd803a4fdbab1f8512e6bc935eb8d8e79ccfb0e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 17:11:05 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 13:11:05 -0400 Subject: [Git][ghc/ghc][master] Add structured error messages for GHC.Rename.Utils Message-ID: <645538a9759dc_e3e062d23d3f4458684@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 30 changed files: - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - testsuite/tests/deSugar/should_compile/ds053.stderr - testsuite/tests/deriving/should_compile/T13919.stderr - testsuite/tests/driver/t22391/t22391.stderr - testsuite/tests/driver/t22391/t22391j.stderr - testsuite/tests/driver/werror.stderr - testsuite/tests/gadt/T12087.stderr - testsuite/tests/gadt/T14320.stderr - testsuite/tests/gadt/T16427.stderr - testsuite/tests/gadt/T18191.stderr - testsuite/tests/ghci/prog018/prog018.stdout - testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr - testsuite/tests/indexed-types/should_compile/T16356_Compile2.stderr - testsuite/tests/indexed-types/should_compile/T16632.stderr - testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr - testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr - testsuite/tests/indexed-types/should_fail/SimpleFail6.stderr - testsuite/tests/indexed-types/should_fail/T16110_Fail1.stderr - testsuite/tests/mdo/should_fail/mdofail002.stderr - testsuite/tests/mdo/should_fail/mdofail003.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/275836d211d119cb8786a91ca3108a4daa693cb2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/275836d211d119cb8786a91ca3108a4daa693cb2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 17:11:44 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 13:11:44 -0400 Subject: [Git][ghc/ghc][master] Use TemplateHaskellQuotes in TH.Syntax to construct Names Message-ID: <645538d09fea2_e3e0622b3d298462053@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - 1 changed file: - libraries/template-haskell/Language/Haskell/TH/Syntax.hs Changes: ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -6,6 +6,7 @@ Trustworthy, DeriveFunctor, BangPatterns, RecordWildCards, ImplicitParams #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} +{-# LANGUAGE TemplateHaskellQuotes #-} ----------------------------------------------------------------------------- -- | @@ -54,7 +55,7 @@ import Data.Ratio import GHC.CString ( unpackCString# ) import GHC.Generics ( Generic ) import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..), - TYPE, RuntimeRep(..) ) + TYPE, RuntimeRep(..), Multiplicity (..) ) import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# ) import GHC.Ptr ( Ptr, plusPtr ) import GHC.Lexeme ( startsVarSym, startsVarId ) @@ -65,7 +66,6 @@ import Prelude hiding (Applicative(..)) import Foreign.ForeignPtr import Foreign.C.String import Foreign.C.Types -import GHC.Stack #if __GLASGOW_HASKELL__ >= 901 import GHC.Types ( Levity(..) ) @@ -1067,8 +1067,7 @@ instance Lift (Fixed.Fixed a) where ex <- lift x return (ConE mkFixedName `AppE` ex) where - mkFixedName = - mkNameG DataName "base" "Data.Fixed" "MkFixed" + mkFixedName = 'Fixed.MkFixed instance Integral a => Lift (Ratio a) where liftTyped x = unsafeCodeCoerce (lift x) @@ -1139,19 +1138,8 @@ instance Lift ByteArray where ptr :: ForeignPtr Word8 ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb)) - --- We can't use a TH quote in this module because we're in the template-haskell --- package, so we conconct this quite defensive solution to make the correct name --- which will work if the package name or module name changes in future. addrToByteArrayName :: Name -addrToByteArrayName = helper - where - helper :: HasCallStack => Name - helper = - case getCallStack ?callStack of - [] -> error "addrToByteArrayName: empty call stack" - (_, SrcLoc{..}) : _ -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray" - +addrToByteArrayName = 'addrToByteArray addrToByteArray :: Int -> Addr# -> ByteArray addrToByteArray (I# len) addr = runST $ ST $ @@ -1371,23 +1359,24 @@ instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) trueName, falseName :: Name -trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" -falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" +trueName = 'True +falseName = 'False nothingName, justName :: Name -nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing" -justName = mkNameG DataName "base" "GHC.Maybe" "Just" +nothingName = 'Nothing +justName = 'Just leftName, rightName :: Name -leftName = mkNameG DataName "base" "Data.Either" "Left" -rightName = mkNameG DataName "base" "Data.Either" "Right" +leftName = 'Left +rightName = 'Right nonemptyName :: Name -nonemptyName = mkNameG DataName "base" "GHC.Base" ":|" +nonemptyName = '(:|) oneName, manyName :: Name -oneName = mkNameG DataName "ghc-prim" "GHC.Types" "One" -manyName = mkNameG DataName "ghc-prim" "GHC.Types" "Many" +oneName = 'One +manyName = 'Many + ----------------------------------------------------- -- -- Generic Lift implementations View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/983ce55815f2dd57f84ee86eee97febf7d80b470 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/983ce55815f2dd57f84ee86eee97febf7d80b470 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 17:42:31 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 13:42:31 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Use TemplateHaskellQuotes in TH.Syntax to construct Names Message-ID: <64554007bc141_e3e0631535c104658b0@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - 9abd0bd8 by Matthew Pickering at 2023-05-05T13:42:22-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 01f0f5a6 by Aaron Allen at 2023-05-05T13:42:22-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 07ccfc64 by Matthew Pickering at 2023-05-05T13:42:22-04:00 docs: Add Note [Timing of plugin initialization] - - - - - ad010960 by Matthew Pickering at 2023-05-05T13:42:22-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 18 changed files: - .gitlab-ci.yml - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Runtime/Loader.hs - ghc/Main.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs - testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs → testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs - + testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs - testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal - testsuite/tests/plugins/plugins04.stderr - testsuite/tests/plugins/test-hooks-plugin.hs - + testsuite/tests/plugins/test-log-hooks-plugin.hs - + testsuite/tests/plugins/test-log-hooks-plugin.stderr - + testsuite/tests/plugins/test-phase-hooks-plugin.hs - + testsuite/tests/plugins/test-phase-hooks-plugin.stderr Changes: ===================================== .gitlab-ci.yml ===================================== @@ -999,7 +999,7 @@ project-version: - . ./version.sh # Download existing ghcup metadata - - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://raw.githubusercontent.com/haskell/ghcup-metadata/develop/ghcup-0.0.7.yaml" + - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://gitlab.haskell.org/ghc/ghcup-metadata/-/raw/updates/ghcup-0.0.7.yaml" - .gitlab/generate_job_metadata @@ -1048,6 +1048,37 @@ ghcup-metadata-nightly: rules: - if: $NIGHTLY +# Update the +ghcup-metadata-nightly-push: + stage: deploy + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + dependencies: null + tags: + - x86_64-linux + variables: + BUILD_FLAVOUR: default + GIT_SUBMODULE_STRATEGY: "none" + needs: + - job: ghcup-metadata-nightly + artifacts: true + script: + - git clone https://gitlab.haskell.org/ghc/ghcup-metadata.git + - cp metadata_test.yaml ghcup-metadata/ghcup-0.0.7.yaml + - cd ghcup-metadata + - git config user.email "ghc-ci at gitlab-haskell.org" + - git config user.name "GHC GitLab CI" + - git remote add gitlab_origin https://oauth2:$PROJECT_PUSH_TOKEN at gitlab.haskell.org/ghc/ghcup-metadata.git + - git add . + - git commit -m "Update metadata" + - git push gitlab_origin HEAD:updates -o ci.skip + rules: + - if: $NIGHTLY + # Only run the update on scheduled nightly pipelines, ie once a day + - if: $CI_PIPELINE_SOURCE == "schedule" + # And only update the metadata for master branch + - if: '$CI_COMMIT_BRANCH == "master"' + + ghcup-metadata-release: # No explicit needs for release pipeline as we assume we need everything and everything will pass. extends: .ghcup-metadata ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -694,6 +694,10 @@ data WorkerLimit -- produced by calling 'depanal'. load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag load' mhmi_cache how_much mHscMessage mod_graph = do + -- In normal usage plugins are initialised already by ghc/Main.hs this is protective + -- for any client who might interact with GHC via load'. + -- See Note [Timing of plugin initialization] + initializeSessionPlugins modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } guessOutputFile hsc_env <- getSession @@ -2852,13 +2856,11 @@ label_self thread_name = do runPipelines :: WorkerLimit -> HscEnv -> Maybe Messager -> [MakeAction] -> IO () -- Don't even initialise plugins if there are no pipelines runPipelines _ _ _ [] = return () -runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do +runPipelines n_job hsc_env mHscMessager all_pipelines = do liftIO $ label_self "main --make thread" - - plugins_hsc_env <- initializePlugins orig_hsc_env case n_job of - NumProcessorsLimit n | n <= 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines - _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines + NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env mHscMessager all_pipelines + _n -> runParPipelines n_job hsc_env mHscMessager all_pipelines runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO () runSeqPipelines plugin_hsc_env mHscMessager all_pipelines = ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -244,12 +244,13 @@ compileOne' mHscMessage addFilesToClean tmpfs TFL_GhcSession $ [ml_obj_file $ ms_location summary] + -- Initialise plugins here for any plugins enabled locally for a module. plugin_hsc_env <- initializePlugins hsc_env let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary mb_old_iface mb_old_linkable (mod_index, nmods) let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status) - (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline + (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline -- See Note [ModDetails and --make mode] details <- initModDetails plugin_hsc_env iface linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable) @@ -526,7 +527,12 @@ findHSLib platform ws dirs lib = do -- Compile files in one-shot mode. oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO () -oneShot hsc_env stop_phase srcs = do +oneShot orig_hsc_env stop_phase srcs = do + -- In oneshot mode, initialise plugins specified on command line + -- we also initialise in ghc/Main but this might be used as an entry point by API clients who + -- should initialise their own plugins but may not. + -- See Note [Timing of plugin initialization] + hsc_env <- initializePlugins orig_hsc_env o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs case stop_phase of StopPreprocess -> return () ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -62,7 +62,6 @@ import GHC.Parser.Header import GHC.Data.StringBuffer import GHC.Types.SourceError import GHC.Unit.Finder -import GHC.Runtime.Loader import Data.IORef import GHC.Types.Name.Env import GHC.Platform.Ways @@ -82,6 +81,7 @@ import GHC.StgToJS.Linker.Linker (embedJsFile) import Language.Haskell.Syntax.Module.Name import GHC.Unit.Home.ModInfo +import GHC.Runtime.Loader (initializePlugins) newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) @@ -724,9 +724,11 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do new_includes = addImplicitQuoteInclude paths [current_dir] paths = includePaths dflags0 dflags = dflags0 { includePaths = new_includes } - hsc_env = hscSetFlags dflags hsc_env0 - + hsc_env1 = hscSetFlags dflags hsc_env0 + -- Initialise plugins as the flags passed into runHscPhase might have local plugins just + -- specific to this module. + hsc_env <- initializePlugins hsc_env1 -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do @@ -786,18 +788,17 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- run the compiler! let msg :: Messager msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what - plugin_hsc_env' <- initializePlugins hsc_env -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } - status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary + status <- hscRecompStatus (Just msg) hsc_env' mod_summary Nothing emptyHomeModInfoLinkable (1, 1) - return (plugin_hsc_env, mod_summary, status) + return (hsc_env', mod_summary, status) -- | Calculate the ModLocation from the provided DynFlags. This function is only used -- in one-shot mode and therefore takes into account the effect of -o/-ohi flags ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -2,7 +2,7 @@ -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader ( - initializePlugins, + initializePlugins, initializeSessionPlugins, -- * Loading plugins loadFrontendPlugin, @@ -74,7 +74,34 @@ import Unsafe.Coerce ( unsafeCoerce ) import GHC.Linker.Types import Data.List (unzip4) import GHC.Iface.Errors.Ppr +import GHC.Driver.Monad +{- Note [Timing of plugin initialization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Plugins needs to be initialised as soon as possible in the pipeline. This is because +driver plugins are executed immediately after being loaded, which can modify anything +in the HscEnv, including the logger and DynFlags (for example #21279). For example, +in ghc/Main.hs the logger is used almost immediately after the session has been initialised +and so if a user overwrites the logger expecting all output to go there then unless +the plugins are initialised before that point then unexpected things will happen. + +We initialise plugins in ghc/Main.hs for the main ghc executable. + +When people are using the GHC API, they also need to initialise plugins +at the highest level possible for things to work as expected. We keep +some defensive calls to plugin initialisation in functions like `load'` and `oneshot` +to catch cases where API users have not initialised their own plugins. + +In addition to this, there needs to be an initialisation call for each module +just in case the user has enabled a plugin just for that module using OPTIONS_GHC +pragma. + +-} + +-- | Initialise plugins specified by the current DynFlags and update the session. +initializeSessionPlugins :: GhcMonad m => m () +initializeSessionPlugins = getSession >>= liftIO . initializePlugins >>= setSession -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before ===================================== ghc/Main.hs ===================================== @@ -41,7 +41,7 @@ import GHC.Platform.Host import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) #endif -import GHC.Runtime.Loader ( loadFrontendPlugin ) +import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins ) import GHC.Unit.Env import GHC.Unit (UnitId, homeUnitDepends) @@ -257,16 +257,23 @@ main' postLoadMode units dflags0 args flagWarnings = do -- we've finished manipulating the DynFlags, update the session _ <- GHC.setSessionDynFlags dflags5 dflags6 <- GHC.getSessionDynFlags - hsc_env <- GHC.getSession + + -- Must do this before loading plugins + liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) + + -- Initialise plugins here because the plugin author might already expect this + -- subsequent call to `getLogger` to be affected by a plugin. + initializeSessionPlugins + hsc_env <- getSession logger <- getLogger + ---------------- Display configuration ----------- case verbosity dflags6 of v | v == 4 -> liftIO $ dumpUnitsSimple hsc_env | v >= 5 -> liftIO $ dumpUnits hsc_env | otherwise -> return () - liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs units ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -6,6 +6,7 @@ Trustworthy, DeriveFunctor, BangPatterns, RecordWildCards, ImplicitParams #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} +{-# LANGUAGE TemplateHaskellQuotes #-} ----------------------------------------------------------------------------- -- | @@ -54,7 +55,7 @@ import Data.Ratio import GHC.CString ( unpackCString# ) import GHC.Generics ( Generic ) import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..), - TYPE, RuntimeRep(..) ) + TYPE, RuntimeRep(..), Multiplicity (..) ) import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# ) import GHC.Ptr ( Ptr, plusPtr ) import GHC.Lexeme ( startsVarSym, startsVarId ) @@ -65,7 +66,6 @@ import Prelude hiding (Applicative(..)) import Foreign.ForeignPtr import Foreign.C.String import Foreign.C.Types -import GHC.Stack #if __GLASGOW_HASKELL__ >= 901 import GHC.Types ( Levity(..) ) @@ -1067,8 +1067,7 @@ instance Lift (Fixed.Fixed a) where ex <- lift x return (ConE mkFixedName `AppE` ex) where - mkFixedName = - mkNameG DataName "base" "Data.Fixed" "MkFixed" + mkFixedName = 'Fixed.MkFixed instance Integral a => Lift (Ratio a) where liftTyped x = unsafeCodeCoerce (lift x) @@ -1139,19 +1138,8 @@ instance Lift ByteArray where ptr :: ForeignPtr Word8 ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb)) - --- We can't use a TH quote in this module because we're in the template-haskell --- package, so we conconct this quite defensive solution to make the correct name --- which will work if the package name or module name changes in future. addrToByteArrayName :: Name -addrToByteArrayName = helper - where - helper :: HasCallStack => Name - helper = - case getCallStack ?callStack of - [] -> error "addrToByteArrayName: empty call stack" - (_, SrcLoc{..}) : _ -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray" - +addrToByteArrayName = 'addrToByteArray addrToByteArray :: Int -> Addr# -> ByteArray addrToByteArray (I# len) addr = runST $ ST $ @@ -1371,23 +1359,24 @@ instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) trueName, falseName :: Name -trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" -falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" +trueName = 'True +falseName = 'False nothingName, justName :: Name -nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing" -justName = mkNameG DataName "base" "GHC.Maybe" "Just" +nothingName = 'Nothing +justName = 'Just leftName, rightName :: Name -leftName = mkNameG DataName "base" "Data.Either" "Left" -rightName = mkNameG DataName "base" "Data.Either" "Right" +leftName = 'Left +rightName = 'Right nonemptyName :: Name -nonemptyName = mkNameG DataName "base" "GHC.Base" ":|" +nonemptyName = '(:|) oneName, manyName :: Name -oneName = mkNameG DataName "ghc-prim" "GHC.Types" "One" -manyName = mkNameG DataName "ghc-prim" "GHC.Types" "Many" +oneName = 'One +manyName = 'Many + ----------------------------------------------------- -- -- Generic Lift implementations ===================================== testsuite/tests/plugins/all.T ===================================== @@ -317,3 +317,17 @@ test('plugins-external', pre_cmd('$MAKE -s --no-print-directory -C shared-plugin package.plugins01 TOP={top}'), when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))], makefile_test, []) + +test('test-phase-hooks-plugin', + [extra_files(['hooks-plugin/']), + pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-phase-hooks-plugin TOP={top}'), + + when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))], + compile, + ['-package-db hooks-plugin/pkg.test-phase-hooks-plugin/local.package.conf -fplugin Hooks.PhasePlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-log-hooks-plugin', + [extra_files(['hooks-plugin/']), + pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], + compile_fail, + ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs ===================================== @@ -0,0 +1,24 @@ +module Hooks.LogPlugin (plugin) where + +import GHC.Plugins +import GHC.Driver.Hooks +import GHC.Tc.Utils.Monad +import GHC.Utils.Logger +import GHC.Driver.Pipeline.Execute +import System.IO + +plugin :: Plugin +plugin = defaultPlugin { driverPlugin = hooksP } + +hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv +hooksP opts hsc_env = do + hSetBuffering stdout NoBuffering + let logger = hsc_logger hsc_env + logger' = pushLogHook logHook logger + hsc_env' = hsc_env { hsc_logger = logger' } + return hsc_env' + +logHook :: LogAction -> LogAction +logHook action logFlags messageClass srcSpan msgDoc = do + putStrLn "Log hook called" + action logFlags messageClass srcSpan msgDoc ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs → testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs ===================================== @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wall #-} -module Hooks.Plugin (plugin) where +module Hooks.MetaPlugin (plugin) where import GHC.Types.SourceText import GHC.Plugins ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs ===================================== @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall #-} +module Hooks.PhasePlugin (plugin) where + +import GHC.Plugins +import GHC.Driver.Hooks +import GHC.Tc.Utils.Monad +import GHC.Driver.Pipeline.Execute +import GHC.Driver.Pipeline.Phases +import System.IO + +plugin :: Plugin +plugin = defaultPlugin { driverPlugin = hooksP } + +hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv +hooksP opts hsc_env = do + hSetBuffering stdout NoBuffering + let hooks = hsc_hooks hsc_env + hooks' = hooks { runPhaseHook = Just fakeRunPhaseHook } + hsc_env' = hsc_env { hsc_hooks = hooks' } + return hsc_env' + +fakeRunPhaseHook :: PhaseHook +fakeRunPhaseHook = PhaseHook $ \tPhase -> do + liftIO $ case tPhase of + T_Cpp{} -> putStrLn "Cpp hook fired" + T_Hsc{} -> putStrLn "Hsc hook fired" + T_FileArgs{} -> putStrLn "FileArgs hook fired" + _ -> pure () + runPhase tPhase ===================================== testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal ===================================== @@ -4,6 +4,6 @@ version: 0.1 build-type: Simple library - exposed-modules: Hooks.Plugin + exposed-modules: Hooks.MetaPlugin, Hooks.PhasePlugin, Hooks.LogPlugin build-depends: base, ghc default-language: Haskell2010 ===================================== testsuite/tests/plugins/plugins04.stderr ===================================== @@ -1,2 +1 @@ -Module graph contains a cycle: - module ‘HomePackagePlugin’ (./HomePackagePlugin.hs) imports itself +attempting to use module ‘main:HomePackagePlugin’ (./HomePackagePlugin.hs) which is not loaded ===================================== testsuite/tests/plugins/test-hooks-plugin.hs ===================================== @@ -1,4 +1,4 @@ -{-# OPTIONS -fplugin=Hooks.Plugin #-} +{-# OPTIONS -fplugin=Hooks.MetaPlugin #-} {-# LANGUAGE TemplateHaskell #-} module Main where ===================================== testsuite/tests/plugins/test-log-hooks-plugin.hs ===================================== @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = pure "type error" ===================================== testsuite/tests/plugins/test-log-hooks-plugin.stderr ===================================== @@ -0,0 +1,9 @@ +Log hook called + +test-log-hooks-plugin.hs:4:13: error: [GHC-83865] + • Couldn't match type ‘[Char]’ with ‘()’ + Expected: () + Actual: String + • In the first argument of ‘pure’, namely ‘"type error"’ + In the expression: pure "type error" + In an equation for ‘main’: main = pure "type error" ===================================== testsuite/tests/plugins/test-phase-hooks-plugin.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} +module Main where + +main :: IO () +main = pure () ===================================== testsuite/tests/plugins/test-phase-hooks-plugin.stderr ===================================== @@ -0,0 +1,5 @@ +FileArgs hook fired +Cpp hook fired +FileArgs hook fired +FileArgs hook fired +Hsc hook fired View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53c2d50d425d31e6aa1bc927df57e5f82e7d9d51...ad0109608cbabb6702e36fd85013ddc9d77020e8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53c2d50d425d31e6aa1bc927df57e5f82e7d9d51...ad0109608cbabb6702e36fd85013ddc9d77020e8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 17:53:18 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Fri, 05 May 2023 13:53:18 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] 2 commits: ROMES:WIP Message-ID: <6455428eafac9_e3e063173913847175c@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: 7da8a61e by Rodrigo Mesquita at 2023-05-05T17:22:01+01:00 ROMES:WIP - - - - - 3243fd3b by Rodrigo Mesquita at 2023-05-05T18:53:09+01:00 ghc-toolchain library and usage in hadrian flags - - - - - 16 changed files: - configure.ac - distrib/configure.ac.in - hadrian/bindist/config.mk.in - hadrian/cabal.project - hadrian/cfg/system.config.in - hadrian/hadrian.cabal - hadrian/src/Base.hs - hadrian/src/Hadrian/Oracles/TextFile.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Settings/Packages.hs - m4/ghc_toolchain.m4 - − m4/ghc_unregisterised.m4 - utils/ghc-toolchain/src/Main.hs → utils/ghc-toolchain/Main.hs - utils/ghc-toolchain/ghc-toolchain.cabal - + utils/ghc-toolchain/src/GHC/Toolchain.hs - utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs Changes: ===================================== configure.ac ===================================== @@ -298,10 +298,28 @@ then exit 1 fi -dnl ** Do an unregisterised build? +dnl ** Flag to override unregisterised build dnl -------------------------------------------------------------- -GHC_UNREGISTERISED +FP_DEFAULT_CHOICE_OVERRIDE_CHECK( + [unregisterised], + [unregisterised], + [registerised], + [Unregisterised], + [Build a toolchain with the unregisterised ABI (disabled by default on platforms with registerised support)], + [NO], + [YES], + [no]) + +dnl ** Flag to override tables next to code +dnl -------------------------------------------------------------- + +FP_DEFAULT_CHOICE_OVERRIDE_CHECK( + [tables-next-to-code], + [tables next to code], + [tables apart from code], + [TablesNextToCode], + [Build a tool chain with info tables laid out next to code (enabled by default when using the registerised ABI, on platforms that support it)]) # Requires FPTOOLS_SET_PLATFORMS_VARS to be run first. FP_FIND_ROOT @@ -310,7 +328,7 @@ FP_FIND_ROOT if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then FP_SETUP_WINDOWS_TOOLCHAIN else - # TODO + # TODO () AC_PATH_TOOL([CC],[gcc], [clang]) AC_PATH_TOOL([CXX],[g++], [clang++]) AC_PATH_TOOL([NM],[nm]) @@ -561,23 +579,12 @@ dnl -------------------------------------------------------------- dnl ** does #! work? AC_SYS_INTERPRETER() -dnl ** look for GCC and find out which version -dnl Figure out which C compiler to use. Gcc is preferred. -dnl If gcc, make sure it's at least 4.7 -dnl -FP_GCC_VERSION - -dnl ** See whether cc supports -no-pie -FP_GCC_SUPPORTS_NO_PIE - dnl ** Used to determine how to compile ghc-prim's atomics.c, used by dnl unregisterised, Sparc, and PPC backends. Also determines whether dnl linking to libatomic is required for atomic operations, e.g. on dnl RISCV64 GCC. FP_CC_SUPPORTS__ATOMICS -FP_GCC_EXTRA_FLAGS - dnl ** look to see if we have a C compiler using an llvm back end. dnl FP_CC_LLVM_BACKEND ===================================== distrib/configure.ac.in ===================================== @@ -149,11 +149,6 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion]) OptCmd="$OPT" AC_SUBST([OptCmd]) -dnl ** Check gcc version and flags we need to pass it ** -FP_GCC_VERSION -FP_GCC_SUPPORTS_NO_PIE -FP_GCC_EXTRA_FLAGS - FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS]) FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAGE1],[CONF_LD_LINKER_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1]) ===================================== hadrian/bindist/config.mk.in ===================================== @@ -234,28 +234,16 @@ GhcRtsWithLibdw=$(strip $(if $(filter $(TargetArch_CPP),i386 x86_64 s390x), at UseL # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] -GccExtraViaCOpts = @GccExtraViaCOpts@ LdHasFilelist = @LdHasFilelist@ LdSupportsResponseFiles = @LdSupportsResponseFiles@ LdHasBuildId = @LdHasBuildId@ LdHasFilelist = @LdHasFilelist@ LdIsGNULd = @LdIsGNULd@ LdHasNoCompactUnwind = @LdHasNoCompactUnwind@ -ArArgs = @ArArgs@ -ArSupportsAtFile = @ArSupportsAtFile@ -ArSupportsDashL = @ArSupportsDashL@ HaskellHostOs = @HaskellHostOs@ HaskellHostArch = @HaskellHostArch@ -HaskellTargetOs = @HaskellTargetOs@ -HaskellTargetArch = @HaskellTargetArch@ -TargetWordSize = @TargetWordSize@ -TargetWordBigEndian = @TargetWordBigEndian@ -TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ -TargetHasIdentDirective = @TargetHasIdentDirective@ -TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ -TablesNextToCode = @TablesNextToCode@ SettingsCCompilerCommand = @SettingsCCompilerCommand@ SettingsCxxCompilerCommand = @SettingsCxxCompilerCommand@ ===================================== hadrian/cabal.project ===================================== @@ -1,4 +1,5 @@ packages: ./ + ../utils/ghc-toolchain/ -- This essentially freezes the build plan for hadrian index-state: 2023-03-30T10:00:00Z ===================================== hadrian/cfg/system.config.in ===================================== @@ -39,9 +39,7 @@ python = @PythonCmd@ # Information about builders: #============================ -ar-supports-at-file = @ArSupportsAtFile@ system-ar-supports-at-file = @ArSupportsAtFile_STAGE0@ -ar-supports-dash-l = @ArSupportsDashL@ system-ar-supports-dash-l = @ArSupportsDashL_STAGE0@ cc-llvm-backend = @CcLlvmBackend@ hs-cpp-args = @HaskellCPPArgs@ @@ -49,11 +47,8 @@ hs-cpp-args = @HaskellCPPArgs@ # Build options: #=============== -ghc-unregisterised = @Unregisterised@ -tables-next-to-code = @TablesNextToCode@ use-libffi-for-adjustors = @UseLibffiForAdjustors@ ghc-source-path = @hardtop@ -leading-underscore = @LeadingUnderscore@ # Information about build, host and target systems: #================================================== @@ -136,12 +131,10 @@ conf-merge-objects-args-stage3 = @MergeObjsArgs@ # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] -gcc-extra-via-c-opts = @GccExtraViaCOpts@ ld-has-no-compact-unwind = @LdHasNoCompactUnwind@ ld-has-filelist = @LdHasFilelist@ ld-supports-response-files = @LdSupportsResponseFiles@ ld-is-gnu-ld = @LdIsGNULd@ -ar-args = @ArArgs@ settings-c-compiler-command = @SettingsCCompilerCommand@ settings-cxx-compiler-command = @SettingsCxxCompilerCommand@ ===================================== hadrian/hadrian.cabal ===================================== @@ -163,6 +163,7 @@ executable hadrian , transformers >= 0.4 && < 0.7 , unordered-containers >= 0.2.1 && < 0.3 , text >= 1.2 && < 3 + , ghc-toolchain ghc-options: -Wall -Wincomplete-record-updates -Wredundant-constraints ===================================== hadrian/src/Base.hs ===================================== @@ -31,6 +31,7 @@ module Base ( -- * Paths hadrianPath, configPath, configFile, sourcePath, shakeFilesDir, stageBinPath, stageLibPath, templateHscPath, + hostTargetFile, targetTargetFile, ghcBinDeps, ghcLibDeps, haddockDeps, relativePackageDbPath, packageDbPath, packageDbStamp, mingwStamp, systemCxxStdLibConf, systemCxxStdLibConfPath @@ -79,6 +80,16 @@ configPath = hadrianPath -/- "cfg" configFile :: FilePath configFile = configPath -/- "system.config" +-- | The target configuration file generated by ghc-toolchain for the +-- compilation host +hostTargetFile :: FilePath +hostTargetFile = "default.target" -- ROMES:TODO: Not hardcode this value? + +-- | The target configuration file generated by ghc-toolchain for the +-- compilation target +targetTargetFile :: FilePath +targetTargetFile = "default.target" -- ROMES:TODO: Not hardcode this value, depends on target + -- | Path to source files of the build system, e.g. this file is located at -- @sourcePath -/- "Base.hs"@. We use this to track some of the source files. sourcePath :: FilePath ===================================== hadrian/src/Hadrian/Oracles/TextFile.hs ===================================== @@ -12,7 +12,8 @@ ----------------------------------------------------------------------------- module Hadrian.Oracles.TextFile ( lookupValue, lookupValueOrEmpty, lookupValueOrError, lookupSystemConfig, lookupValues, - lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies, textFileOracle + lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies, textFileOracle, + getHostTargetConfig, getTargetTargetConfig ) where import Control.Monad @@ -24,6 +25,8 @@ import Development.Shake.Classes import Development.Shake.Config import Base +import qualified GHC.Toolchain.Target as Toolchain + -- | Lookup a value in a text file, tracking the result. Each line of the file -- is expected to have @key = value@ format. lookupValue :: FilePath -> String -> Action (Maybe String) @@ -79,6 +82,21 @@ lookupDependencies depFile file = do Just [] -> error $ "No source file found for file " ++ quote file Just (source : files) -> return (source, files) +-- | Parse a target from a text file, tracking the result. The file is expected +-- to contain a parseable Toolchain.Target value generated by ghc-toolchain. +getTargetConfig :: FilePath -> Action Toolchain.Target +getTargetConfig file = askOracle $ TargetFile file + +-- | Get the host's target configuration through 'getTarget' +getHostTargetConfig :: Action Toolchain.Target +getHostTargetConfig = getTargetConfig hostTargetFile + -- where + -- msg = "The host's target configuration file " ++ quote hostTargetFile ++ " does not exist! ghc-toolchain might have failed to generate it." + +-- | Get the target's target configuration through 'getTarget' +getTargetTargetConfig :: Action Toolchain.Target +getTargetTargetConfig = getTargetConfig targetTargetFile + newtype KeyValue = KeyValue (FilePath, String) deriving (Binary, Eq, Hashable, NFData, Show, Typeable) type instance RuleResult KeyValue = Maybe String @@ -87,6 +105,10 @@ newtype KeyValues = KeyValues (FilePath, String) deriving (Binary, Eq, Hashable, NFData, Show, Typeable) type instance RuleResult KeyValues = Maybe [String] +newtype TargetFile = TargetFile FilePath + deriving (Binary, Eq, Hashable, NFData, Show, Typeable) +type instance RuleResult TargetFile = Toolchain.Target + -- | These oracle rules are used to cache and track answers to the following -- queries, which are implemented by parsing text files: -- @@ -97,6 +119,10 @@ type instance RuleResult KeyValues = Maybe [String] -- -- 2) Parsing Makefile dependency files generated by commands like @gcc -MM@: -- see 'lookupDependencies'. +-- +-- 3) Parsing target files as generated by ghc-toolchain. See functions +-- 'lookupTarget' and lookupTargetConfig' +-- textFileOracle :: Rules () textFileOracle = do kv <- newCache $ \file -> do @@ -111,3 +137,27 @@ textFileOracle = do contents <- map words <$> readFileLines file return $ Map.fromList [ (key, values) | (key:values) <- contents ] void $ addOracleCache $ \(KeyValues (file, key)) -> Map.lookup key <$> kvs file + + tf <- newCache $ \file -> do + need [file] + putVerbose $ "| TargetFile oracle: reading " ++ quote file ++ "..." + target <- read <$> readFile' file + return (target :: Toolchain.Target) + void $ addOracle $ \(TargetFile file) -> tf file + +-- ROMES:TODO: get back to this!!!!!! +instance Eq Toolchain.Target where + (==) _ _ = True + +instance Ord Toolchain.Target where + (<=) _ _ = False +instance Hashable Toolchain.Target where + hashWithSalt _ _ = 0 +instance Binary Toolchain.Target where + put _ = undefined + get = undefined + +instance NFData Toolchain.Target where + rnf _ = () + + ===================================== hadrian/src/Oracles/Flag.hs ===================================== @@ -17,6 +17,9 @@ import Hadrian.Expression import Base import Oracles.Setting +import GHC.Toolchain.Target (Target(..)) +import qualified GHC.Toolchain as Toolchain + data Flag = ArSupportsAtFile | ArSupportsDashL | SystemArSupportsAtFile @@ -44,38 +47,50 @@ data Flag = ArSupportsAtFile | UseLibpthread | NeedLibatomic +data FlagKey = SystemConfigKey String + | HostTargetKey (Toolchain.Target -> Bool) + | TargetTargetKey (Toolchain.Target -> Bool) + -- Note, if a flag is set to empty string we treat it as set to NO. This seems -- fragile, but some flags do behave like this. flag :: Flag -> Action Bool flag f = do - let key = case f of - ArSupportsAtFile -> "ar-supports-at-file" - ArSupportsDashL -> "ar-supports-dash-l" - SystemArSupportsAtFile-> "system-ar-supports-at-file" - SystemArSupportsDashL-> "system-ar-supports-dash-l" - CrossCompiling -> "cross-compiling" - CcLlvmBackend -> "cc-llvm-backend" - GhcUnregisterised -> "ghc-unregisterised" - TablesNextToCode -> "tables-next-to-code" - GmpInTree -> "intree-gmp" - GmpFrameworkPref -> "gmp-framework-preferred" - LeadingUnderscore -> "leading-underscore" - UseSystemFfi -> "use-system-ffi" - BootstrapThreadedRts -> "bootstrap-threaded-rts" - BootstrapEventLoggingRts -> "bootstrap-event-logging-rts" - UseLibffiForAdjustors -> "use-libffi-for-adjustors" - UseLibdw -> "use-lib-dw" - UseLibnuma -> "use-lib-numa" - UseLibm -> "use-lib-m" - UseLibrt -> "use-lib-rt" - UseLibdl -> "use-lib-dl" - UseLibbfd -> "use-lib-bfd" - UseLibpthread -> "use-lib-pthread" - NeedLibatomic -> "need-libatomic" - value <- lookupSystemConfig key - when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag " - ++ quote (key ++ " = " ++ value) ++ " cannot be parsed." - return $ value == "YES" + let flagkey :: FlagKey = case f of + ArSupportsAtFile -> TargetTargetKey (Toolchain.arSupportsAtFile . tgtAr) + ArSupportsDashL -> TargetTargetKey (Toolchain.arSupportsDashL . tgtAr) + SystemArSupportsAtFile-> HostTargetKey (Toolchain.arSupportsAtFile . tgtAr) + SystemArSupportsDashL-> HostTargetKey (Toolchain.arSupportsDashL . tgtAr) + CrossCompiling -> SystemConfigKey "cross-compiling" + CcLlvmBackend -> SystemConfigKey "cc-llvm-backend" + GhcUnregisterised -> TargetTargetKey tgtUnregisterised + TablesNextToCode -> TargetTargetKey tgtTablesNextToCode + GmpInTree -> SystemConfigKey "intree-gmp" + GmpFrameworkPref -> SystemConfigKey "gmp-framework-preferred" + LeadingUnderscore -> TargetTargetKey tgtSymbolsHaveLeadingUnderscore + UseSystemFfi -> SystemConfigKey "use-system-ffi" + BootstrapThreadedRts -> SystemConfigKey "bootstrap-threaded-rts" + BootstrapEventLoggingRts -> SystemConfigKey "bootstrap-event-logging-rts" + UseLibffiForAdjustors -> SystemConfigKey "use-libffi-for-adjustors" + UseLibdw -> SystemConfigKey "use-lib-dw" + UseLibnuma -> SystemConfigKey "use-lib-numa" + UseLibm -> SystemConfigKey "use-lib-m" + UseLibrt -> SystemConfigKey "use-lib-rt" + UseLibdl -> SystemConfigKey "use-lib-dl" + UseLibbfd -> SystemConfigKey "use-lib-bfd" + UseLibpthread -> SystemConfigKey "use-lib-pthread" + NeedLibatomic -> SystemConfigKey "need-libatomic" + case flagkey of + SystemConfigKey key -> do + value <- lookupSystemConfig key + when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag " + ++ quote (key ++ " = " ++ value) ++ " cannot be parsed." + return $ value == "YES" + HostTargetKey key -> do + value <- key <$> getHostTargetConfig + return value + TargetTargetKey key -> do + value <- key <$> getTargetTargetConfig + return value -- | Get a configuration setting. getFlag :: Flag -> Expr c b Bool ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -276,7 +276,7 @@ rtsPackageArgs = package rts ? do way <- getWay path <- getBuildPath top <- expr topDirectory - useSystemFfi <- expr $ flag UseSystemFfi + useSystemFfi <- getFlag UseSystemFfi ffiIncludeDir <- getSetting FfiIncludeDir ffiLibraryDir <- getSetting FfiLibDir libdwIncludeDir <- getSetting LibdwIncludeDir ===================================== m4/ghc_toolchain.m4 ===================================== @@ -20,7 +20,9 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--triple=$target" >> acargs echo "--cc=$CC" >> acargs ADD_GHC_TOOLCHAIN_ARG([cc-opt], [$CONF_CC_OPTS_STAGE1]) - # TODO + # TODO (previously we had in configure script use of --traditional??) + # First thing disable the comment: + # Also, differentiatiate between hscpp and cpp? #echo "--cpp=$CPP" >> acargs ADD_GHC_TOOLCHAIN_ARG([cpp-opt], [$CONF_CPP_OPTS_STAGE1]) echo "--cc-link=$CC" >> acargs @@ -42,7 +44,11 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--disable-unregisterised" >> acargs fi - # TODO: TNTC + if test "$TablesNextToCode" = "YES"; then + echo "--enable-tables-next-to-code" >> acargs + else + echo "--disable-tables-next-to-code" >> acargs + fi ( set -- @@ -50,7 +56,7 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], set -- "[$]@" "$arg" done ./acghc-toolchain "[$]@" || exit 1 - python -c 'import sys; print(sys.argv)' "[$]@" + python3 -c 'import sys; print(sys.argv)' "[$]@" ) M a -> IO (Either [Error] a) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f02181995fcccea4e456431db8698dfd7a1309d6...3243fd3b5275a445d703c5e122ab1573ba097152 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f02181995fcccea4e456431db8698dfd7a1309d6...3243fd3b5275a445d703c5e122ab1573ba097152 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 19:52:40 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Fri, 05 May 2023 15:52:40 -0400 Subject: [Git][ghc/ghc][wip/decode_cloned_stack] Improve comments Message-ID: <64555e882c382_e3e0633cc6dec49412e@gitlab.mail> Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC Commits: 7cd3dda6 by Ben Gamari at 2023-05-05T19:52:38+00:00 Improve comments - - - - - 1 changed file: - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs Changes: ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -365,15 +365,15 @@ data GenClosure b -- | A primitive word from a bitmap encoded stack frame payload -- - -- The type itself cannot be restored (i.e. it might also represent a byte - -- or an int). + -- The type itself cannot be restored (i.e. it might represent a Word8# + -- or an Int#). | UnknownTypeWordSizedPrimitive { wordVal :: !Word } deriving (Show, Generic, Functor, Foldable, Traversable) -- | A decoded @StgStack@ with `StackFrame`s -- --- This is separate from it's `Closure` incarnation, as unification would +-- This is separate from its `Closure` incarnation, as unification would -- require two kinds of boxes for bitmap encoded stack content: One for -- primitives and one for closures. This turned out to be a nightmare with lots -- of pattern matches and leaking data structures to enable access to primitives View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cd3dda60f9593804a7770609f39a4983b8ca298 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cd3dda60f9593804a7770609f39a4983b8ca298 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 20:00:13 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Fri, 05 May 2023 16:00:13 -0400 Subject: [Git][ghc/ghc][wip/decode_cloned_stack] 136 commits: Add support for -debug in the testsuite Message-ID: <6455604d4720c_e3e0631535c104946f7@gitlab.mail> Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC Commits: bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00 Set base 'maintainer' field to CLC - - - - - ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00 Clarify a couple of Notes about 'nospec' - - - - - ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - 71c0f118 by Sven Tennie at 2023-05-05T19:59:52+00:00 ghc-heap: Decode StgStack and its frames Previously, ghc-heap could only decode heap closures. The approach is explained in detail in note [Decoding the stack]. - - - - - cc3d412d by Sven Tennie at 2023-05-05T19:59:52+00:00 Splitting StackFrames from Closures: Compiles - - - - - eccb5e42 by Sven Tennie at 2023-05-05T19:59:52+00:00 Fix tests - - - - - 80faa5b7 by Sven Tennie at 2023-05-05T19:59:52+00:00 Validate - - - - - 81f592f3 by Sven Tennie at 2023-05-05T19:59:52+00:00 Remove unnecessary instances - - - - - 633487f9 by Sven Tennie at 2023-05-05T19:59:52+00:00 Smaller diff - - - - - b479f2b3 by Sven Tennie at 2023-05-05T19:59:52+00:00 Add comment - - - - - c3b6d2de by Sven Tennie at 2023-05-05T19:59:52+00:00 Add comment - - - - - 97792e9a by Sven Tennie at 2023-05-05T19:59:52+00:00 Add C function signatures to Cmm for readability - - - - - 1b265cfd by Sven Tennie at 2023-05-05T19:59:52+00:00 Better assertion message - - - - - 9006a2f1 by Sven Tennie at 2023-05-05T19:59:53+00:00 More iterations to get more underflow frames - - - - - e85771ba by Sven Tennie at 2023-05-05T19:59:53+00:00 Rename - - - - - fec74c95 by Sven Tennie at 2023-05-05T19:59:53+00:00 getClosure returns Closure - - - - - 1590209b by Sven Tennie at 2023-05-05T19:59:53+00:00 getClosure: One WordOffset is enough - - - - - 9306ac1f by Sven Tennie at 2023-05-05T19:59:53+00:00 getWord: One offset is enough - - - - - 5d015c94 by Sven Tennie at 2023-05-05T19:59:53+00:00 decodeBitmaps: One offset is enough - - - - - 2577ee98 by Sven Tennie at 2023-05-05T19:59:53+00:00 Formatting, notes - - - - - 1a917069 by Sven Tennie at 2023-05-05T19:59:53+00:00 Minimize diff - - - - - 56fe2462 by Sven Tennie at 2023-05-05T19:59:53+00:00 Fix overloaded naming issues - - - - - a58284ad by Sven Tennie at 2023-05-05T19:59:53+00:00 Reduce diff - - - - - dbffeb4b by Sven Tennie at 2023-05-05T19:59:53+00:00 Use function level pattern match - - - - - bc4da44d by Sven Tennie at 2023-05-05T19:59:53+00:00 Simpify bitmap decoding - - - - - 87c1f82f by Sven Tennie at 2023-05-05T19:59:53+00:00 Get rid of StackFrameIter - - - - - 3557c62f by Sven Tennie at 2023-05-05T19:59:53+00:00 Formatting - - - - - c2ec6788 by Sven Tennie at 2023-05-05T19:59:53+00:00 Add docs / rename - - - - - 373f0f22 by Sven Tennie at 2023-05-05T19:59:53+00:00 Cleanup - - - - - 62c74837 by Sven Tennie at 2023-05-05T19:59:53+00:00 Printer: Add missing frame support - - - - - 0a77b364 by Sven Tennie at 2023-05-05T19:59:53+00:00 Printer: More readable RET_FUN code - - - - - e83bba0d by Sven Tennie at 2023-05-05T19:59:53+00:00 Haddock - - - - - ecab6705 by Sven Tennie at 2023-05-05T19:59:53+00:00 Simplify stackHead - - - - - e94cd054 by Sven Tennie at 2023-05-05T19:59:53+00:00 Formatting - - - - - 2e7ab0e5 by Sven Tennie at 2023-05-05T19:59:53+00:00 Rename: getBoxedClosure -> getStackClosure - - - - - 1a685641 by Sven Tennie at 2023-05-05T19:59:53+00:00 Document Cmm return values - - - - - b57e4efc by Sven Tennie at 2023-05-05T19:59:53+00:00 Un-IO getWord - - - - - 72e3ee93 by Sven Tennie at 2023-05-05T19:59:53+00:00 Un-IO getUnderflowFrameNextChunk - - - - - 67f4ff68 by Sven Tennie at 2023-05-05T19:59:53+00:00 Un-IO getRetFunType - - - - - f041876d by Sven Tennie at 2023-05-05T19:59:53+00:00 Un-IO LargeBitmapGetter - - - - - 50d23617 by Sven Tennie at 2023-05-05T19:59:53+00:00 Un-IO SmallBitmapGetter - - - - - 6ea11206 by Sven Tennie at 2023-05-05T19:59:53+00:00 Formatting and one comment - - - - - e7a1b015 by Sven Tennie at 2023-05-05T19:59:53+00:00 Add missing bang patterns to StackFrames - - - - - 96dc4ee1 by Sven Tennie at 2023-05-05T19:59:53+00:00 Try more general data structure - - - - - 867c723f by Ben Gamari at 2023-05-05T19:59:53+00:00 Improve comments - - - - - 8acd9250 by Sven Tennie at 2023-05-05T19:59:53+00:00 Fix test - - - - - 69495779 by Sven Tennie at 2023-05-05T19:59:53+00:00 Inline - - - - - fce1eec4 by Sven Tennie at 2023-05-05T19:59:53+00:00 Fix test - - - - - 2f714b69 by Sven Tennie at 2023-05-05T19:59:53+00:00 Improve docs - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/Wasm/Types.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core/InstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7cd3dda60f9593804a7770609f39a4983b8ca298...2f714b698664045e77476905517120f27c0aee30 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7cd3dda60f9593804a7770609f39a4983b8ca298...2f714b698664045e77476905517120f27c0aee30 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 20:51:11 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 05 May 2023 16:51:11 -0400 Subject: [Git][ghc/ghc][wip/T23333] 3 commits: Add structured error messages for GHC.Rename.Utils Message-ID: <64556c3f753c0_e3e0633cc6dec49944d@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23333 at Glasgow Haskell Compiler / GHC Commits: 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5c1de98 by Simon Peyton Jones at 2023-05-05T21:51:05+01:00 Look both ways when looking for quantified equalities When looking up (t1 ~# t2) in the quantified constraints, check both orientations. Forgetting this led to #23333. - - - - - 30 changed files: - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Interact.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/deSugar/should_compile/ds053.stderr - testsuite/tests/deriving/should_compile/T13919.stderr - testsuite/tests/driver/t22391/t22391.stderr - testsuite/tests/driver/t22391/t22391j.stderr - testsuite/tests/driver/werror.stderr - testsuite/tests/gadt/T12087.stderr - testsuite/tests/gadt/T14320.stderr - testsuite/tests/gadt/T16427.stderr - testsuite/tests/gadt/T18191.stderr - testsuite/tests/ghci/prog018/prog018.stdout - testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr - testsuite/tests/indexed-types/should_compile/T16356_Compile2.stderr - testsuite/tests/indexed-types/should_compile/T16632.stderr - testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/264162062e7327d89bd7baf5a45cbe3105558f8b...a5c1de9893d7496903989c12353ec903c049ed6c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/264162062e7327d89bd7baf5a45cbe3105558f8b...a5c1de9893d7496903989c12353ec903c049ed6c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 21:18:39 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Fri, 05 May 2023 17:18:39 -0400 Subject: [Git][ghc/ghc][wip/expand-do] - Discard default monad fail alternatives that are spuriously generated Message-ID: <645572af5cb45_e3e063580eb04502068@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: adc71cd6 by Apoorv Ingle at 2023-05-05T16:14:23-05:00 - Discard default monad fail alternatives that are spuriously generated - Make sure we check for generated loc span for checking if the (>>) is user written or expanded for /do/ purposes - - - - - 8 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1114,9 +1114,9 @@ data HsExpansion orig expanded -- | Just print the original expression (the @a@) with the expanded version (the @b@) instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ppr (HsExpanded orig expanded) - -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - -- (ppr orig) - = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) + = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) + (ppr orig) + -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) {- ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -39,7 +39,7 @@ module GHC.Hs.Pat ( mkPrefixConPat, mkCharLitPat, mkNilPat, - isSimplePat, + isSimplePat, isPatSyn, looksLazyPatBind, isBangedLPat, gParPat, patNeedsParens, parenthesizePat, @@ -617,6 +617,10 @@ isSimplePat p = case unLoc p of VarPat _ x -> Just (unLoc x) _ -> Nothing +isPatSyn :: LPat GhcTc -> Bool +isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True +isPatSyn _ = False + {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -858,21 +858,19 @@ warnDiscardedDoBindings rhs rhs_ty warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM () warnUnusedBindValue fun arg arg_ty - | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun + | Just (SrcSpanAnn _ l, f) <- fish_var fun , is_gen_then f - -- , isNoSrcSpan l + , isGeneratedSrcSpan l = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun - , text "arg" <+> ppr arg - , text "arg_ty" <+> ppr arg_ty - , text "f" <+> ppr f <+> ppr (is_gen_then f) - , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc) + , text "loc" <+> ppr l <+> ppr loc + , text "locGen?" <+> ppr (isGeneratedSrcSpan l) <+> ppr (isGeneratedSrcSpan loc) + , text "noLoc?" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc) ]) warnDiscardedDoBindings arg arg_ty where -- retrieve the location info and the head of the application - fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc) + fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , Id) fish_var (L l (HsVar _ id)) = return (l, id) - fish_var (L _ (PopSrcSpan e)) = pprPanic "warnUnusedBindValue" (ppr e) fish_var (L _ (HsAppType _ e _ _)) = fish_var e fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e) return (l, e') ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -227,7 +227,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty match_groups [] = matchEmpty v ty match_groups (g:gs) = mapM match_group $ g :| gs - match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr) + match_group :: NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr) match_group eqns@((group,_) :| _) = case group of PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) @@ -767,12 +767,15 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 -} -matchWrapper ctxt scrs (MG { mg_alts = L _ matches +matchWrapper ctxt scrs (MG { mg_alts = L _ matches' , mg_ext = MatchGroupTc arg_tys rhs_ty origin }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs - + ; let matches = if any (is_pat_syn_match origin) matches' + then filter (non_wc origin) matches' -- filter out the wild pattern fail alternatives that + -- generate spurious overlapping warnings + else matches' ; new_vars <- case matches of [] -> newSysLocalsDs arg_tys (m:_) -> @@ -827,7 +830,13 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches $ NEL.nonEmpty $ replicate (length (grhssGRHSs m)) initNablas - + is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool + is_pat_syn_match Generated (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat + is_pat_syn_match _ _ = False + non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool + non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False + non_wc _ _ = True + matchEquations :: HsMatchContext GhcRn -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -91,7 +91,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModGuts import GHC.Types.Name.Reader -import GHC.Types.Basic ( Origin ) +import GHC.Types.Basic ( Origin (..) ) import GHC.Types.SourceFile import GHC.Types.Id import GHC.Types.Var (EvId) ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -325,7 +325,9 @@ tcApp rn_expr exp_res_ty | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr = do { traceTc "tcApp {" $ vcat [ text "rn_fun:" <+> ppr rn_fun - , text "rn_args:" <+> ppr rn_args ] + , text "rn_args:" <+> ppr rn_args + , text "fun_ctxt:" <+> ppr fun_ctxt <+> ppr (appCtxtLoc fun_ctxt) + ] ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -1383,17 +1383,16 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc mk_failable_lexpr_tcm pat lexpr fail_op = do { tc_env <- getGblEnv ; is_strict <- xoptM LangExt.Strict - ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat + ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat , ppr $ isIrrefutableHsPatRn tc_env is_strict pat ]) ; if isIrrefutableHsPatRn tc_env is_strict pat - -- don't decorate with fail statement if the pattern is irrefutable - -- pattern syns always get a fail block while desugaring so skip + -- don't decorate with fail statement if + -- 1) the pattern is irrefutable then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } - where -- makes the fail block -- TODO: check the discussion around MonadFail.fail type signature. ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1623,9 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs - +-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool -isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL where goL :: LPat GhcRn -> Bool goL = go . unLoc @@ -1649,11 +1649,22 @@ isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = go (ConPat { pat_con = L _ dcName - , pat_args = details }) = case lookupTypeEnv type_env dcName of - Just (ATyCon con) -> - isJust (tyConSingleDataCon_maybe con) - && all goL (hsConPatArgs details) - _ -> False -- conservative. + , pat_args = details }) = + case lookupTypeEnv type_env dcName of + Just (ATyCon tycon) -> + (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon) + && all goL (hsConPatArgs details) + Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) + Just (AConLike cl) -> case cl of + RealDataCon dc -> let tycon = dataConTyCon dc in + (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon) + && all goL (hsConPatArgs details) + PatSynCon _ -> False -- conservative + + Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) + _ -> False -- conservative. go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adc71cd6eb04db55279b7bd5784185292b2ab374 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adc71cd6eb04db55279b7bd5784185292b2ab374 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 21:41:17 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Fri, 05 May 2023 17:41:17 -0400 Subject: [Git][ghc/ghc][wip/expand-do] - Discard default monad fail alternatives that are spuriously generated Message-ID: <645577fd8bb8d_e3e063580eaf05028bf@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 372ad22d by Apoorv Ingle at 2023-05-05T16:41:09-05:00 - Discard default monad fail alternatives that are spuriously generated - Make sure we check for generated loc span for checking if the (>>) is user written or expanded for /do/ purposes - - - - - 8 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1114,9 +1114,9 @@ data HsExpansion orig expanded -- | Just print the original expression (the @a@) with the expanded version (the @b@) instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ppr (HsExpanded orig expanded) - -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - -- (ppr orig) - = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) + = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) + (ppr orig) + -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) {- ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -39,7 +39,7 @@ module GHC.Hs.Pat ( mkPrefixConPat, mkCharLitPat, mkNilPat, - isSimplePat, + isSimplePat, isPatSyn, looksLazyPatBind, isBangedLPat, gParPat, patNeedsParens, parenthesizePat, @@ -617,6 +617,10 @@ isSimplePat p = case unLoc p of VarPat _ x -> Just (unLoc x) _ -> Nothing +isPatSyn :: LPat GhcTc -> Bool +isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True +isPatSyn _ = False + {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -858,21 +858,21 @@ warnDiscardedDoBindings rhs rhs_ty warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM () warnUnusedBindValue fun arg arg_ty - | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun + | Just (l, f) <- fish_var fun , is_gen_then f - -- , isNoSrcSpan l + , isGeneratedSrcSpan l = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun - , text "arg" <+> ppr arg - , text "arg_ty" <+> ppr arg_ty - , text "f" <+> ppr f <+> ppr (is_gen_then f) - , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc) + , text "loc" <+> ppr l + , text "locGen?" <+> ppr (isGeneratedSrcSpan l) + , text "noLoc?" <+> ppr (isNoSrcSpan l) ]) warnDiscardedDoBindings arg arg_ty where -- retrieve the location info and the head of the application - fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc) - fish_var (L l (HsVar _ id)) = return (l, id) - fish_var (L _ (PopSrcSpan e)) = pprPanic "warnUnusedBindValue" (ppr e) + -- It is important that we /do not/ look through HsApp to avoid + -- generating duplicate warnings + fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id) + fish_var (L l (HsVar _ id)) = return (locA l, unLoc id) fish_var (L _ (HsAppType _ e _ _)) = fish_var e fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e) return (l, e') ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -227,7 +227,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty match_groups [] = matchEmpty v ty match_groups (g:gs) = mapM match_group $ g :| gs - match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr) + match_group :: NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr) match_group eqns@((group,_) :| _) = case group of PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) @@ -767,12 +767,15 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 -} -matchWrapper ctxt scrs (MG { mg_alts = L _ matches +matchWrapper ctxt scrs (MG { mg_alts = L _ matches' , mg_ext = MatchGroupTc arg_tys rhs_ty origin }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs - + ; let matches = if any (is_pat_syn_match origin) matches' + then filter (non_wc origin) matches' -- filter out the wild pattern fail alternatives that + -- generate spurious overlapping warnings + else matches' ; new_vars <- case matches of [] -> newSysLocalsDs arg_tys (m:_) -> @@ -827,7 +830,13 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches $ NEL.nonEmpty $ replicate (length (grhssGRHSs m)) initNablas - + is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool + is_pat_syn_match Generated (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat + is_pat_syn_match _ _ = False + non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool + non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False + non_wc _ _ = True + matchEquations :: HsMatchContext GhcRn -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -91,7 +91,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModGuts import GHC.Types.Name.Reader -import GHC.Types.Basic ( Origin ) +import GHC.Types.Basic ( Origin (..) ) import GHC.Types.SourceFile import GHC.Types.Id import GHC.Types.Var (EvId) ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -325,7 +325,9 @@ tcApp rn_expr exp_res_ty | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr = do { traceTc "tcApp {" $ vcat [ text "rn_fun:" <+> ppr rn_fun - , text "rn_args:" <+> ppr rn_args ] + , text "rn_args:" <+> ppr rn_args + , text "fun_ctxt:" <+> ppr fun_ctxt <+> ppr (appCtxtLoc fun_ctxt) + ] ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -1383,17 +1383,16 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc mk_failable_lexpr_tcm pat lexpr fail_op = do { tc_env <- getGblEnv ; is_strict <- xoptM LangExt.Strict - ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat + ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat , ppr $ isIrrefutableHsPatRn tc_env is_strict pat ]) ; if isIrrefutableHsPatRn tc_env is_strict pat - -- don't decorate with fail statement if the pattern is irrefutable - -- pattern syns always get a fail block while desugaring so skip + -- don't decorate with fail statement if + -- 1) the pattern is irrefutable then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } - where -- makes the fail block -- TODO: check the discussion around MonadFail.fail type signature. ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1623,9 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs - +-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool -isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL where goL :: LPat GhcRn -> Bool goL = go . unLoc @@ -1649,11 +1649,22 @@ isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = go (ConPat { pat_con = L _ dcName - , pat_args = details }) = case lookupTypeEnv type_env dcName of - Just (ATyCon con) -> - isJust (tyConSingleDataCon_maybe con) - && all goL (hsConPatArgs details) - _ -> False -- conservative. + , pat_args = details }) = + case lookupTypeEnv type_env dcName of + Just (ATyCon tycon) -> + (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon) + && all goL (hsConPatArgs details) + Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) + Just (AConLike cl) -> case cl of + RealDataCon dc -> let tycon = dataConTyCon dc in + (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon) + && all goL (hsConPatArgs details) + PatSynCon _ -> False -- conservative + + Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) + _ -> False -- conservative. go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/372ad22d9f9cc27bfa6880f4754475ccc7a1d505 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/372ad22d9f9cc27bfa6880f4754475ccc7a1d505 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 21:42:40 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Fri, 05 May 2023 17:42:40 -0400 Subject: [Git][ghc/ghc][wip/expand-do] - Discard default monad fail alternatives that are spuriously generated Message-ID: <6455785027356_e3e063430e8945036b8@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 4f8d5755 by Apoorv Ingle at 2023-05-05T16:42:27-05:00 - Discard default monad fail alternatives that are spuriously generated - Make sure we check for generated loc span for checking if the (>>) is user written or expanded for /do/ purposes - - - - - 8 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1114,9 +1114,9 @@ data HsExpansion orig expanded -- | Just print the original expression (the @a@) with the expanded version (the @b@) instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ppr (HsExpanded orig expanded) - -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - -- (ppr orig) - = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) + = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) + (ppr orig) + -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) {- ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -39,7 +39,7 @@ module GHC.Hs.Pat ( mkPrefixConPat, mkCharLitPat, mkNilPat, - isSimplePat, + isSimplePat, isPatSyn, looksLazyPatBind, isBangedLPat, gParPat, patNeedsParens, parenthesizePat, @@ -617,6 +617,10 @@ isSimplePat p = case unLoc p of VarPat _ x -> Just (unLoc x) _ -> Nothing +isPatSyn :: LPat GhcTc -> Bool +isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True +isPatSyn _ = False + {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -858,31 +858,27 @@ warnDiscardedDoBindings rhs rhs_ty warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM () warnUnusedBindValue fun arg arg_ty - | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun - , is_gen_then f - -- , isNoSrcSpan l + | Just (l, f) <- fish_var fun + , f `hasKey` thenMClassOpKey -- it is a (>>) + , isGeneratedSrcSpan l -- it is compiler generated = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun - , text "arg" <+> ppr arg - , text "arg_ty" <+> ppr arg_ty - , text "f" <+> ppr f <+> ppr (is_gen_then f) - , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc) + , text "loc" <+> ppr l + , text "locGen?" <+> ppr (isGeneratedSrcSpan l) + , text "noLoc?" <+> ppr (isNoSrcSpan l) ]) warnDiscardedDoBindings arg arg_ty where -- retrieve the location info and the head of the application - fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc) - fish_var (L l (HsVar _ id)) = return (l, id) - fish_var (L _ (PopSrcSpan e)) = pprPanic "warnUnusedBindValue" (ppr e) + -- It is important that we /do not/ look through HsApp to avoid + -- generating duplicate warnings + fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id) + fish_var (L l (HsVar _ id)) = return (locA l, unLoc id) fish_var (L _ (HsAppType _ e _ _)) = fish_var e fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e) return (l, e') fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e) fish_var _ = Nothing - -- is this id a compiler generated (>>) with expanded do - is_gen_then :: Id -> Bool - is_gen_then f = f `hasKey` thenMClassOpKey - warnUnusedBindValue _ _ _ = return () ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -227,7 +227,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty match_groups [] = matchEmpty v ty match_groups (g:gs) = mapM match_group $ g :| gs - match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr) + match_group :: NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr) match_group eqns@((group,_) :| _) = case group of PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) @@ -767,12 +767,15 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 -} -matchWrapper ctxt scrs (MG { mg_alts = L _ matches +matchWrapper ctxt scrs (MG { mg_alts = L _ matches' , mg_ext = MatchGroupTc arg_tys rhs_ty origin }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs - + ; let matches = if any (is_pat_syn_match origin) matches' + then filter (non_wc origin) matches' -- filter out the wild pattern fail alternatives that + -- generate spurious overlapping warnings + else matches' ; new_vars <- case matches of [] -> newSysLocalsDs arg_tys (m:_) -> @@ -827,7 +830,13 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches $ NEL.nonEmpty $ replicate (length (grhssGRHSs m)) initNablas - + is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool + is_pat_syn_match Generated (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat + is_pat_syn_match _ _ = False + non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool + non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False + non_wc _ _ = True + matchEquations :: HsMatchContext GhcRn -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -91,7 +91,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModGuts import GHC.Types.Name.Reader -import GHC.Types.Basic ( Origin ) +import GHC.Types.Basic ( Origin (..) ) import GHC.Types.SourceFile import GHC.Types.Id import GHC.Types.Var (EvId) ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -325,7 +325,9 @@ tcApp rn_expr exp_res_ty | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr = do { traceTc "tcApp {" $ vcat [ text "rn_fun:" <+> ppr rn_fun - , text "rn_args:" <+> ppr rn_args ] + , text "rn_args:" <+> ppr rn_args + , text "fun_ctxt:" <+> ppr fun_ctxt <+> ppr (appCtxtLoc fun_ctxt) + ] ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -1383,17 +1383,16 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc mk_failable_lexpr_tcm pat lexpr fail_op = do { tc_env <- getGblEnv ; is_strict <- xoptM LangExt.Strict - ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat + ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat , ppr $ isIrrefutableHsPatRn tc_env is_strict pat ]) ; if isIrrefutableHsPatRn tc_env is_strict pat - -- don't decorate with fail statement if the pattern is irrefutable - -- pattern syns always get a fail block while desugaring so skip + -- don't decorate with fail statement if + -- 1) the pattern is irrefutable then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } - where -- makes the fail block -- TODO: check the discussion around MonadFail.fail type signature. ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1623,9 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs - +-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool -isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL where goL :: LPat GhcRn -> Bool goL = go . unLoc @@ -1649,11 +1649,22 @@ isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = go (ConPat { pat_con = L _ dcName - , pat_args = details }) = case lookupTypeEnv type_env dcName of - Just (ATyCon con) -> - isJust (tyConSingleDataCon_maybe con) - && all goL (hsConPatArgs details) - _ -> False -- conservative. + , pat_args = details }) = + case lookupTypeEnv type_env dcName of + Just (ATyCon tycon) -> + (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon) + && all goL (hsConPatArgs details) + Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) + Just (AConLike cl) -> case cl of + RealDataCon dc -> let tycon = dataConTyCon dc in + (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon) + && all goL (hsConPatArgs details) + PatSynCon _ -> False -- conservative + + Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) + _ -> False -- conservative. go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f8d57550995e70a60bf7d7972cd4a65190dbdec -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f8d57550995e70a60bf7d7972cd4a65190dbdec You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 21:44:49 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Fri, 05 May 2023 17:44:49 -0400 Subject: [Git][ghc/ghc][wip/expand-do] - Discard default monad fail alternatives that are spuriously generated Message-ID: <645578d170a58_e3e0635685238504281@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 6f3e0a3c by Apoorv Ingle at 2023-05-05T16:44:39-05:00 - Discard default monad fail alternatives that are spuriously generated - Make sure we check for generated loc span for checking if the (>>) is user written or expanded for /do/ purposes - - - - - 8 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1114,9 +1114,9 @@ data HsExpansion orig expanded -- | Just print the original expression (the @a@) with the expanded version (the @b@) instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ppr (HsExpanded orig expanded) - -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - -- (ppr orig) - = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) + = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) + (ppr orig) + -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded) {- ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -39,7 +39,7 @@ module GHC.Hs.Pat ( mkPrefixConPat, mkCharLitPat, mkNilPat, - isSimplePat, + isSimplePat, isPatSyn, looksLazyPatBind, isBangedLPat, gParPat, patNeedsParens, parenthesizePat, @@ -617,6 +617,10 @@ isSimplePat p = case unLoc p of VarPat _ x -> Just (unLoc x) _ -> Nothing +isPatSyn :: LPat GhcTc -> Bool +isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True +isPatSyn _ = False + {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -858,31 +858,27 @@ warnDiscardedDoBindings rhs rhs_ty warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM () warnUnusedBindValue fun arg arg_ty - | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun - , is_gen_then f - -- , isNoSrcSpan l + | Just (l, f) <- fish_var fun + , f `hasKey` thenMClassOpKey -- it is a (>>) + , isGeneratedSrcSpan l -- it is compiler generated = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun - , text "arg" <+> ppr arg - , text "arg_ty" <+> ppr arg_ty - , text "f" <+> ppr f <+> ppr (is_gen_then f) - , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc) + , text "loc" <+> ppr l + , text "locGen?" <+> ppr (isGeneratedSrcSpan l) + , text "noLoc?" <+> ppr (isNoSrcSpan l) ]) warnDiscardedDoBindings arg arg_ty where -- retrieve the location info and the head of the application - fish_var :: LHsExpr GhcTc -> Maybe (SrcSpanAnnA , LIdP GhcTc) - fish_var (L l (HsVar _ id)) = return (l, id) - fish_var (L _ (PopSrcSpan e)) = pprPanic "warnUnusedBindValue" (ppr e) + -- It is important that we /do not/ look through HsApp to avoid + -- generating duplicate warnings + fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id) + fish_var (L l (HsVar _ id)) = return (locA l, unLoc id) fish_var (L _ (HsAppType _ e _ _)) = fish_var e fish_var (L l (XExpr (WrapExpr (HsWrap _ e)))) = do (l, e') <- fish_var (L l e) return (l, e') fish_var (L l (XExpr (ExpansionExpr (HsExpanded _ e)))) = fish_var (L l e) fish_var _ = Nothing - -- is this id a compiler generated (>>) with expanded do - is_gen_then :: Id -> Bool - is_gen_then f = f `hasKey` thenMClassOpKey - warnUnusedBindValue _ _ _ = return () ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -227,7 +227,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty match_groups [] = matchEmpty v ty match_groups (g:gs) = mapM match_group $ g :| gs - match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr) + match_group :: NonEmpty (PatGroup, EquationInfo) -> DsM (MatchResult CoreExpr) match_group eqns@((group,_) :| _) = case group of PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) @@ -767,12 +767,15 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 -} -matchWrapper ctxt scrs (MG { mg_alts = L _ matches +matchWrapper ctxt scrs (MG { mg_alts = L _ matches' , mg_ext = MatchGroupTc arg_tys rhs_ty origin }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs - + ; let matches = if any (is_pat_syn_match origin) matches' + then filter (non_wc origin) matches' -- filter out the wild pattern fail alternatives that + -- generate spurious overlapping warnings + else matches' ; new_vars <- case matches of [] -> newSysLocalsDs arg_tys (m:_) -> @@ -827,7 +830,13 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches $ NEL.nonEmpty $ replicate (length (grhssGRHSs m)) initNablas - + is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool + is_pat_syn_match Generated (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat + is_pat_syn_match _ _ = False + non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool + non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False + non_wc _ _ = True + matchEquations :: HsMatchContext GhcRn -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -91,7 +91,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModGuts import GHC.Types.Name.Reader -import GHC.Types.Basic ( Origin ) +import GHC.Types.Basic ( Origin (..) ) import GHC.Types.SourceFile import GHC.Types.Id import GHC.Types.Var (EvId) ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -325,7 +325,9 @@ tcApp rn_expr exp_res_ty | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr = do { traceTc "tcApp {" $ vcat [ text "rn_fun:" <+> ppr rn_fun - , text "rn_args:" <+> ppr rn_args ] + , text "rn_args:" <+> ppr rn_args + , text "fun_ctxt:" <+> ppr fun_ctxt <+> ppr (appCtxtLoc fun_ctxt) + ] ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -1383,17 +1383,16 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc mk_failable_lexpr_tcm pat lexpr fail_op = do { tc_env <- getGblEnv ; is_strict <- xoptM LangExt.Strict - ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat + ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat , ppr $ isIrrefutableHsPatRn tc_env is_strict pat ]) ; if isIrrefutableHsPatRn tc_env is_strict pat - -- don't decorate with fail statement if the pattern is irrefutable - -- pattern syns always get a fail block while desugaring so skip + -- don't decorate with fail statement if + -- 1) the pattern is irrefutable then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } - where -- makes the fail block -- TODO: check the discussion around MonadFail.fail type signature. ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1623,9 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs - +-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool -isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL where goL :: LPat GhcRn -> Bool goL = go . unLoc @@ -1649,11 +1649,22 @@ isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = go (ConPat { pat_con = L _ dcName - , pat_args = details }) = case lookupTypeEnv type_env dcName of - Just (ATyCon con) -> - isJust (tyConSingleDataCon_maybe con) - && all goL (hsConPatArgs details) - _ -> False -- conservative. + , pat_args = details }) = + case lookupTypeEnv type_env dcName of + Just (ATyCon tycon) -> + (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon) + && all goL (hsConPatArgs details) + Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) + Just (AConLike cl) -> case cl of + RealDataCon dc -> let tycon = dataConTyCon dc in + (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon) + && all goL (hsConPatArgs details) + PatSynCon _ -> False -- conservative + + Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) + _ -> False -- conservative. go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6f3e0a3cf048015761819ab9bd0e848c90a7ecf8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6f3e0a3cf048015761819ab9bd0e848c90a7ecf8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 22:42:53 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 18:42:53 -0400 Subject: [Git][ghc/ghc][master] 3 commits: driver: Use hooks from plugin_hsc_env Message-ID: <6455866d331a5_e3e0636322aa451094a@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - 16 changed files: - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Runtime/Loader.hs - ghc/Main.hs - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs - testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs → testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs - + testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs - testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal - testsuite/tests/plugins/plugins04.stderr - testsuite/tests/plugins/test-hooks-plugin.hs - + testsuite/tests/plugins/test-log-hooks-plugin.hs - + testsuite/tests/plugins/test-log-hooks-plugin.stderr - + testsuite/tests/plugins/test-phase-hooks-plugin.hs - + testsuite/tests/plugins/test-phase-hooks-plugin.stderr Changes: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -694,6 +694,10 @@ data WorkerLimit -- produced by calling 'depanal'. load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag load' mhmi_cache how_much mHscMessage mod_graph = do + -- In normal usage plugins are initialised already by ghc/Main.hs this is protective + -- for any client who might interact with GHC via load'. + -- See Note [Timing of plugin initialization] + initializeSessionPlugins modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } guessOutputFile hsc_env <- getSession @@ -2852,13 +2856,11 @@ label_self thread_name = do runPipelines :: WorkerLimit -> HscEnv -> Maybe Messager -> [MakeAction] -> IO () -- Don't even initialise plugins if there are no pipelines runPipelines _ _ _ [] = return () -runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do +runPipelines n_job hsc_env mHscMessager all_pipelines = do liftIO $ label_self "main --make thread" - - plugins_hsc_env <- initializePlugins orig_hsc_env case n_job of - NumProcessorsLimit n | n <= 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines - _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines + NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env mHscMessager all_pipelines + _n -> runParPipelines n_job hsc_env mHscMessager all_pipelines runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO () runSeqPipelines plugin_hsc_env mHscMessager all_pipelines = ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -244,12 +244,13 @@ compileOne' mHscMessage addFilesToClean tmpfs TFL_GhcSession $ [ml_obj_file $ ms_location summary] + -- Initialise plugins here for any plugins enabled locally for a module. plugin_hsc_env <- initializePlugins hsc_env let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary mb_old_iface mb_old_linkable (mod_index, nmods) let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status) - (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline + (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline -- See Note [ModDetails and --make mode] details <- initModDetails plugin_hsc_env iface linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable) @@ -526,7 +527,12 @@ findHSLib platform ws dirs lib = do -- Compile files in one-shot mode. oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO () -oneShot hsc_env stop_phase srcs = do +oneShot orig_hsc_env stop_phase srcs = do + -- In oneshot mode, initialise plugins specified on command line + -- we also initialise in ghc/Main but this might be used as an entry point by API clients who + -- should initialise their own plugins but may not. + -- See Note [Timing of plugin initialization] + hsc_env <- initializePlugins orig_hsc_env o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs case stop_phase of StopPreprocess -> return () ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -62,7 +62,6 @@ import GHC.Parser.Header import GHC.Data.StringBuffer import GHC.Types.SourceError import GHC.Unit.Finder -import GHC.Runtime.Loader import Data.IORef import GHC.Types.Name.Env import GHC.Platform.Ways @@ -82,6 +81,7 @@ import GHC.StgToJS.Linker.Linker (embedJsFile) import Language.Haskell.Syntax.Module.Name import GHC.Unit.Home.ModInfo +import GHC.Runtime.Loader (initializePlugins) newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) @@ -724,9 +724,11 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do new_includes = addImplicitQuoteInclude paths [current_dir] paths = includePaths dflags0 dflags = dflags0 { includePaths = new_includes } - hsc_env = hscSetFlags dflags hsc_env0 - + hsc_env1 = hscSetFlags dflags hsc_env0 + -- Initialise plugins as the flags passed into runHscPhase might have local plugins just + -- specific to this module. + hsc_env <- initializePlugins hsc_env1 -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do @@ -786,18 +788,17 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- run the compiler! let msg :: Messager msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what - plugin_hsc_env' <- initializePlugins hsc_env -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } - status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary + status <- hscRecompStatus (Just msg) hsc_env' mod_summary Nothing emptyHomeModInfoLinkable (1, 1) - return (plugin_hsc_env, mod_summary, status) + return (hsc_env', mod_summary, status) -- | Calculate the ModLocation from the provided DynFlags. This function is only used -- in one-shot mode and therefore takes into account the effect of -o/-ohi flags ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -2,7 +2,7 @@ -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader ( - initializePlugins, + initializePlugins, initializeSessionPlugins, -- * Loading plugins loadFrontendPlugin, @@ -74,7 +74,34 @@ import Unsafe.Coerce ( unsafeCoerce ) import GHC.Linker.Types import Data.List (unzip4) import GHC.Iface.Errors.Ppr +import GHC.Driver.Monad +{- Note [Timing of plugin initialization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Plugins needs to be initialised as soon as possible in the pipeline. This is because +driver plugins are executed immediately after being loaded, which can modify anything +in the HscEnv, including the logger and DynFlags (for example #21279). For example, +in ghc/Main.hs the logger is used almost immediately after the session has been initialised +and so if a user overwrites the logger expecting all output to go there then unless +the plugins are initialised before that point then unexpected things will happen. + +We initialise plugins in ghc/Main.hs for the main ghc executable. + +When people are using the GHC API, they also need to initialise plugins +at the highest level possible for things to work as expected. We keep +some defensive calls to plugin initialisation in functions like `load'` and `oneshot` +to catch cases where API users have not initialised their own plugins. + +In addition to this, there needs to be an initialisation call for each module +just in case the user has enabled a plugin just for that module using OPTIONS_GHC +pragma. + +-} + +-- | Initialise plugins specified by the current DynFlags and update the session. +initializeSessionPlugins :: GhcMonad m => m () +initializeSessionPlugins = getSession >>= liftIO . initializePlugins >>= setSession -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before ===================================== ghc/Main.hs ===================================== @@ -41,7 +41,7 @@ import GHC.Platform.Host import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) #endif -import GHC.Runtime.Loader ( loadFrontendPlugin ) +import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins ) import GHC.Unit.Env import GHC.Unit (UnitId, homeUnitDepends) @@ -257,16 +257,23 @@ main' postLoadMode units dflags0 args flagWarnings = do -- we've finished manipulating the DynFlags, update the session _ <- GHC.setSessionDynFlags dflags5 dflags6 <- GHC.getSessionDynFlags - hsc_env <- GHC.getSession + + -- Must do this before loading plugins + liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) + + -- Initialise plugins here because the plugin author might already expect this + -- subsequent call to `getLogger` to be affected by a plugin. + initializeSessionPlugins + hsc_env <- getSession logger <- getLogger + ---------------- Display configuration ----------- case verbosity dflags6 of v | v == 4 -> liftIO $ dumpUnitsSimple hsc_env | v >= 5 -> liftIO $ dumpUnits hsc_env | otherwise -> return () - liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs units ===================================== testsuite/tests/plugins/all.T ===================================== @@ -317,3 +317,17 @@ test('plugins-external', pre_cmd('$MAKE -s --no-print-directory -C shared-plugin package.plugins01 TOP={top}'), when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))], makefile_test, []) + +test('test-phase-hooks-plugin', + [extra_files(['hooks-plugin/']), + pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-phase-hooks-plugin TOP={top}'), + + when(opsys('linux') and not ghc_dynamic(), expect_broken(20706))], + compile, + ['-package-db hooks-plugin/pkg.test-phase-hooks-plugin/local.package.conf -fplugin Hooks.PhasePlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-log-hooks-plugin', + [extra_files(['hooks-plugin/']), + pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], + compile_fail, + ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs ===================================== @@ -0,0 +1,24 @@ +module Hooks.LogPlugin (plugin) where + +import GHC.Plugins +import GHC.Driver.Hooks +import GHC.Tc.Utils.Monad +import GHC.Utils.Logger +import GHC.Driver.Pipeline.Execute +import System.IO + +plugin :: Plugin +plugin = defaultPlugin { driverPlugin = hooksP } + +hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv +hooksP opts hsc_env = do + hSetBuffering stdout NoBuffering + let logger = hsc_logger hsc_env + logger' = pushLogHook logHook logger + hsc_env' = hsc_env { hsc_logger = logger' } + return hsc_env' + +logHook :: LogAction -> LogAction +logHook action logFlags messageClass srcSpan msgDoc = do + putStrLn "Log hook called" + action logFlags messageClass srcSpan msgDoc ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs → testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs ===================================== @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wall #-} -module Hooks.Plugin (plugin) where +module Hooks.MetaPlugin (plugin) where import GHC.Types.SourceText import GHC.Plugins ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs ===================================== @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall #-} +module Hooks.PhasePlugin (plugin) where + +import GHC.Plugins +import GHC.Driver.Hooks +import GHC.Tc.Utils.Monad +import GHC.Driver.Pipeline.Execute +import GHC.Driver.Pipeline.Phases +import System.IO + +plugin :: Plugin +plugin = defaultPlugin { driverPlugin = hooksP } + +hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv +hooksP opts hsc_env = do + hSetBuffering stdout NoBuffering + let hooks = hsc_hooks hsc_env + hooks' = hooks { runPhaseHook = Just fakeRunPhaseHook } + hsc_env' = hsc_env { hsc_hooks = hooks' } + return hsc_env' + +fakeRunPhaseHook :: PhaseHook +fakeRunPhaseHook = PhaseHook $ \tPhase -> do + liftIO $ case tPhase of + T_Cpp{} -> putStrLn "Cpp hook fired" + T_Hsc{} -> putStrLn "Hsc hook fired" + T_FileArgs{} -> putStrLn "FileArgs hook fired" + _ -> pure () + runPhase tPhase ===================================== testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal ===================================== @@ -4,6 +4,6 @@ version: 0.1 build-type: Simple library - exposed-modules: Hooks.Plugin + exposed-modules: Hooks.MetaPlugin, Hooks.PhasePlugin, Hooks.LogPlugin build-depends: base, ghc default-language: Haskell2010 ===================================== testsuite/tests/plugins/plugins04.stderr ===================================== @@ -1,2 +1 @@ -Module graph contains a cycle: - module ‘HomePackagePlugin’ (./HomePackagePlugin.hs) imports itself +attempting to use module ‘main:HomePackagePlugin’ (./HomePackagePlugin.hs) which is not loaded ===================================== testsuite/tests/plugins/test-hooks-plugin.hs ===================================== @@ -1,4 +1,4 @@ -{-# OPTIONS -fplugin=Hooks.Plugin #-} +{-# OPTIONS -fplugin=Hooks.MetaPlugin #-} {-# LANGUAGE TemplateHaskell #-} module Main where ===================================== testsuite/tests/plugins/test-log-hooks-plugin.hs ===================================== @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = pure "type error" ===================================== testsuite/tests/plugins/test-log-hooks-plugin.stderr ===================================== @@ -0,0 +1,9 @@ +Log hook called + +test-log-hooks-plugin.hs:4:13: error: [GHC-83865] + • Couldn't match type ‘[Char]’ with ‘()’ + Expected: () + Actual: String + • In the first argument of ‘pure’, namely ‘"type error"’ + In the expression: pure "type error" + In an equation for ‘main’: main = pure "type error" ===================================== testsuite/tests/plugins/test-phase-hooks-plugin.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} +module Main where + +main :: IO () +main = pure () ===================================== testsuite/tests/plugins/test-phase-hooks-plugin.stderr ===================================== @@ -0,0 +1,5 @@ +FileArgs hook fired +Cpp hook fired +FileArgs hook fired +FileArgs hook fired +Hsc hook fired View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/983ce55815f2dd57f84ee86eee97febf7d80b470...6e776ed33dfbdd288064001039235de6d2174d8a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/983ce55815f2dd57f84ee86eee97febf7d80b470...6e776ed33dfbdd288064001039235de6d2174d8a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 22:43:21 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 18:43:21 -0400 Subject: [Git][ghc/ghc][master] Incrementally update ghcup metadata in ghc/ghcup-metadata Message-ID: <64558689d7bab_e3e0635685238514590@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -999,7 +999,7 @@ project-version: - . ./version.sh # Download existing ghcup metadata - - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://raw.githubusercontent.com/haskell/ghcup-metadata/develop/ghcup-0.0.7.yaml" + - nix shell --extra-experimental-features nix-command --extra-experimental-features flakes nixpkgs#wget -c wget "https://gitlab.haskell.org/ghc/ghcup-metadata/-/raw/updates/ghcup-0.0.7.yaml" - .gitlab/generate_job_metadata @@ -1048,6 +1048,37 @@ ghcup-metadata-nightly: rules: - if: $NIGHTLY +# Update the +ghcup-metadata-nightly-push: + stage: deploy + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" + dependencies: null + tags: + - x86_64-linux + variables: + BUILD_FLAVOUR: default + GIT_SUBMODULE_STRATEGY: "none" + needs: + - job: ghcup-metadata-nightly + artifacts: true + script: + - git clone https://gitlab.haskell.org/ghc/ghcup-metadata.git + - cp metadata_test.yaml ghcup-metadata/ghcup-0.0.7.yaml + - cd ghcup-metadata + - git config user.email "ghc-ci at gitlab-haskell.org" + - git config user.name "GHC GitLab CI" + - git remote add gitlab_origin https://oauth2:$PROJECT_PUSH_TOKEN at gitlab.haskell.org/ghc/ghcup-metadata.git + - git add . + - git commit -m "Update metadata" + - git push gitlab_origin HEAD:updates -o ci.skip + rules: + - if: $NIGHTLY + # Only run the update on scheduled nightly pipelines, ie once a day + - if: $CI_PIPELINE_SOURCE == "schedule" + # And only update the metadata for master branch + - if: '$CI_COMMIT_BRANCH == "master"' + + ghcup-metadata-release: # No explicit needs for release pipeline as we assume we need everything and everything will pass. extends: .ghcup-metadata View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e1df8511e45e9071aa5e488ac21c4ccd24d91837 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e1df8511e45e9071aa5e488ac21c4ccd24d91837 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri May 5 23:14:31 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 19:14:31 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: driver: Use hooks from plugin_hsc_env Message-ID: <64558dd79cf_e3e0637d5a50c519791@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 6d4236c6 by Rodrigo Mesquita at 2023-05-05T19:14:14-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - d21dfdfa by Torsten Schmits at 2023-05-05T19:14:26-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 30 changed files: - .gitlab-ci.yml - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/exts/ffi.rst - docs/users_guide/using-warnings.rst - ghc/Main.hs - testsuite/tests/mdo/should_compile/mdo002.hs - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs - testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs → testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs - + testsuite/tests/plugins/hooks-plugin/Hooks/PhasePlugin.hs - testsuite/tests/plugins/hooks-plugin/hooks-plugin.cabal - testsuite/tests/plugins/plugins04.stderr - testsuite/tests/plugins/test-hooks-plugin.hs - + testsuite/tests/plugins/test-log-hooks-plugin.hs - + testsuite/tests/plugins/test-log-hooks-plugin.stderr - + testsuite/tests/plugins/test-phase-hooks-plugin.hs - + testsuite/tests/plugins/test-phase-hooks-plugin.stderr - testsuite/tests/polykinds/MonoidsFD.hs - testsuite/tests/polykinds/MonoidsTF.hs - testsuite/tests/profiling/should_run/T3001-2.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ad0109608cbabb6702e36fd85013ddc9d77020e8...d21dfdfa320d24999a8c23c20a9e6a47cc36d385 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ad0109608cbabb6702e36fd85013ddc9d77020e8...d21dfdfa320d24999a8c23c20a9e6a47cc36d385 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 01:21:51 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Fri, 05 May 2023 21:21:51 -0400 Subject: [Git][ghc/ghc][wip/expand-do] experimenting with irrefutable patterns Message-ID: <6455abafa1eb0_e3e0639f844985330bb@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: a0785856 by Apoorv Ingle at 2023-05-05T20:21:39-05:00 experimenting with irrefutable patterns - - - - - 2 changed files: - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -1383,11 +1383,12 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc mk_failable_lexpr_tcm pat lexpr fail_op = do { tc_env <- getGblEnv ; is_strict <- xoptM LangExt.Strict + ; b <- isIrrefutableHsPatRn tc_env is_strict pat ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat - , ppr $ isIrrefutableHsPatRn tc_env is_strict pat + , text "isIrrefutable:" <+> ppr b ]) - ; if isIrrefutableHsPatRn tc_env is_strict pat + ; if b -- don't decorate with fail statement if -- 1) the pattern is irrefutable then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1623,55 +1623,77 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs --- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the -isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool -isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL +-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on type checking +isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> TcM Bool +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = + do traceTc "isIrrefutableHsPatRn" empty + goL pat where - goL :: LPat GhcRn -> Bool + goL :: LPat GhcRn -> TcM Bool goL = go . unLoc - go :: Pat GhcRn -> Bool - go (WildPat {}) = True - go (VarPat {}) = True + go :: Pat GhcRn -> TcM Bool + go (WildPat {}) = return True + go (VarPat {}) = return True go (LazyPat _ p') | is_strict = isIrrefutableHsPatRn tc_env False p' - | otherwise = True + | otherwise = return True go (BangPat _ pat) = goL pat go (ParPat _ _ pat _) = goL pat go (AsPat _ _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat - go (TuplePat _ pats _) = all goL pats - go (SumPat {}) = False + go (TuplePat _ pats _) = + do traceTc "isIrrefutableHsPatRn TuplePat" empty + foldM (\a p -> do {b <- goL p; return (a && b)}) True pats + + go (SumPat {}) = return False -- See Note [Unboxed sum patterns aren't irrefutable] - go (ListPat {}) = False + go (ListPat {}) = return False go (ConPat { pat_con = L _ dcName , pat_args = details }) = case lookupTypeEnv type_env dcName of - Just (ATyCon tycon) -> - (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon) - && all goL (hsConPatArgs details) + Just (ATyCon tycon) -> do + b <- foldM (\a p -> do {b <- goL p; return (a && b)}) True (hsConPatArgs details) + traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon + , ppr (isNewTyCon tycon) + , ppr (tcHasFixedRuntimeRep tycon)]) + let b' = (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon + || tcHasFixedRuntimeRep tycon) + return (b && b') Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) - Just (AConLike cl) -> case cl of - RealDataCon dc -> let tycon = dataConTyCon dc in - (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon) - && all goL (hsConPatArgs details) - PatSynCon _ -> False -- conservative + Just (AConLike cl) -> + case cl of + RealDataCon dc -> + do let tycon = dataConTyCon dc + b <- foldM (\a p -> do {b <- goL p; return (a && b)}) + True (hsConPatArgs details) + traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon + , ppr (isNewTyCon tycon) + , ppr (tcHasFixedRuntimeRep tycon)] ) + let b' = (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon + || tcHasFixedRuntimeRep tycon) + return (b && b') + PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con) + return False -- conservative Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) - _ -> False -- conservative. - go (LitPat {}) = False - go (NPat {}) = False - go (NPlusKPat {}) = False + Nothing -> do traceTc "isIrrefutableHsPatRn no tycon" empty + return True -- this may not be the right thing to do + go (LitPat {}) = do traceTc "isIrrefutableHsPatRn LitPat" empty + return False + go (NPat {}) = return False + go (NPlusKPat {}) = return False -- We conservatively assume that no TH splices are irrefutable -- since we cannot know until the splice is evaluated. - go (SplicePat {}) = False + go (SplicePat {}) = return False go (XPat ext) = case ext of - HsPatExpanded _ pat -> go pat + HsPatExpanded _ pat -> do traceTc "isIrrefutableHsPatRn HsPatEx" empty + go pat View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a07858562ef9733d0c7fd7cc64fc868d2e574c6a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a07858562ef9733d0c7fd7cc64fc868d2e574c6a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 01:51:55 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Fri, 05 May 2023 21:51:55 -0400 Subject: [Git][ghc/ghc][wip/expand-do] experimenting with irrefutable patterns Message-ID: <6455b2bb6ab67_e3e0637e7031053368b@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: ab8861a6 by Apoorv Ingle at 2023-05-05T20:51:44-05:00 experimenting with irrefutable patterns - - - - - 2 changed files: - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -1383,11 +1383,12 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc mk_failable_lexpr_tcm pat lexpr fail_op = do { tc_env <- getGblEnv ; is_strict <- xoptM LangExt.Strict + ; b <- isIrrefutableHsPatRn tc_env is_strict pat ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat - , ppr $ isIrrefutableHsPatRn tc_env is_strict pat + , text "isIrrefutable:" <+> ppr b ]) - ; if isIrrefutableHsPatRn tc_env is_strict pat + ; if b -- don't decorate with fail statement if -- 1) the pattern is irrefutable then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1623,55 +1623,78 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs --- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the -isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool -isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL +-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on type checking +isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> TcM Bool +isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = + do traceTc "isIrrefutableHsPatRn" empty + goL pat where - goL :: LPat GhcRn -> Bool + goL :: LPat GhcRn -> TcM Bool goL = go . unLoc - go :: Pat GhcRn -> Bool - go (WildPat {}) = True - go (VarPat {}) = True + go :: Pat GhcRn -> TcM Bool + go (WildPat {}) = return True + go (VarPat {}) = return True go (LazyPat _ p') | is_strict = isIrrefutableHsPatRn tc_env False p' - | otherwise = True + | otherwise = return True go (BangPat _ pat) = goL pat go (ParPat _ _ pat _) = goL pat go (AsPat _ _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat - go (TuplePat _ pats _) = all goL pats - go (SumPat {}) = False + go (TuplePat _ pats _) = + do traceTc "isIrrefutableHsPatRn TuplePat" empty + foldM (\a p -> do {b <- goL p; return (a && b)}) True pats + + go (SumPat {}) = return False -- See Note [Unboxed sum patterns aren't irrefutable] - go (ListPat {}) = False + go (ListPat {}) = return False go (ConPat { pat_con = L _ dcName , pat_args = details }) = - case lookupTypeEnv type_env dcName of - Just (ATyCon tycon) -> - (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon) - && all goL (hsConPatArgs details) - Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) - Just (AConLike cl) -> case cl of - RealDataCon dc -> let tycon = dataConTyCon dc in - (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon) - && all goL (hsConPatArgs details) - PatSynCon _ -> False -- conservative - - Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) - _ -> False -- conservative. - go (LitPat {}) = False - go (NPat {}) = False - go (NPlusKPat {}) = False + do { tyth <- tcLookupGlobal dcName + ; traceTc "isIrrefutableHsPatRn dataCon" (ppr tyth) + ; case tyth of + (ATyCon tycon) -> + do { b <- foldM (\a p -> do {b <- goL p; return (a && b)}) True (hsConPatArgs details) + ; traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon + , ppr (isNewTyCon tycon) + , ppr (tcHasFixedRuntimeRep tycon)]) + ; let b' = (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon + || tcHasFixedRuntimeRep tycon) + ; return (b && b') } + id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) + (AConLike cl) -> + case cl of + RealDataCon dc -> + do let tycon = dataConTyCon dc + b <- foldM (\a p -> do {b <- goL p; return (a && b)}) + True (hsConPatArgs details) + traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon + , ppr (isNewTyCon tycon) + , ppr (tcHasFixedRuntimeRep tycon)] ) + let b' = (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon + || tcHasFixedRuntimeRep tycon) + return (b && b') + PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con) + return False -- conservative + + ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) + } + go (LitPat {}) = do traceTc "isIrrefutableHsPatRn LitPat" empty + return False + go (NPat {}) = return False + go (NPlusKPat {}) = return False -- We conservatively assume that no TH splices are irrefutable -- since we cannot know until the splice is evaluated. - go (SplicePat {}) = False + go (SplicePat {}) = return False go (XPat ext) = case ext of - HsPatExpanded _ pat -> go pat + HsPatExpanded _ pat -> do traceTc "isIrrefutableHsPatRn HsPatEx" empty + go pat View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab8861a684d86355df6be6837a52f0beca19501f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab8861a684d86355df6be6837a52f0beca19501f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 02:01:54 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Fri, 05 May 2023 22:01:54 -0400 Subject: [Git][ghc/ghc][wip/expand-do] experimenting with irrefutable patterns Message-ID: <6455b5127f40c_e3e0637e7031053445b@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 4e9c64e6 by Apoorv Ingle at 2023-05-05T21:01:42-05:00 experimenting with irrefutable patterns - - - - - 3 changed files: - compiler/GHC/HsToCore/Match.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -836,7 +836,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches' non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False non_wc _ _ = True - + matchEquations :: HsMatchContext GhcRn -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -1383,11 +1383,12 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc mk_failable_lexpr_tcm pat lexpr fail_op = do { tc_env <- getGblEnv ; is_strict <- xoptM LangExt.Strict + ; b <- isIrrefutableHsPatRn tc_env is_strict pat ; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat - , ppr $ isIrrefutableHsPatRn tc_env is_strict pat + , text "isIrrefutable:" <+> ppr b ]) - ; if isIrrefutableHsPatRn tc_env is_strict pat + ; if b -- don't decorate with fail statement if -- 1) the pattern is irrefutable then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -41,7 +41,6 @@ import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Reader -import GHC.Types.TypeEnv (lookupTypeEnv) import GHC.Core.Multiplicity import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env @@ -1623,55 +1622,78 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs --- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the -isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool -isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL +-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on type checking +isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> TcM Bool +isIrrefutableHsPatRn _ is_strict pat = + do traceTc "isIrrefutableHsPatRn" empty + goL pat where - goL :: LPat GhcRn -> Bool + goL :: LPat GhcRn -> TcM Bool goL = go . unLoc - go :: Pat GhcRn -> Bool - go (WildPat {}) = True - go (VarPat {}) = True + go :: Pat GhcRn -> TcM Bool + go (WildPat {}) = return True + go (VarPat {}) = return True go (LazyPat _ p') | is_strict = isIrrefutableHsPatRn tc_env False p' - | otherwise = True + | otherwise = return True go (BangPat _ pat) = goL pat go (ParPat _ _ pat _) = goL pat go (AsPat _ _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat - go (TuplePat _ pats _) = all goL pats - go (SumPat {}) = False + go (TuplePat _ pats _) = + do traceTc "isIrrefutableHsPatRn TuplePat" empty + foldM (\a p -> do {b <- goL p; return (a && b)}) True pats + + go (SumPat {}) = return False -- See Note [Unboxed sum patterns aren't irrefutable] - go (ListPat {}) = False + go (ListPat {}) = return False go (ConPat { pat_con = L _ dcName , pat_args = details }) = - case lookupTypeEnv type_env dcName of - Just (ATyCon tycon) -> - (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon) - && all goL (hsConPatArgs details) - Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) - Just (AConLike cl) -> case cl of - RealDataCon dc -> let tycon = dataConTyCon dc in - (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon) - && all goL (hsConPatArgs details) - PatSynCon _ -> False -- conservative - - Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) - _ -> False -- conservative. - go (LitPat {}) = False - go (NPat {}) = False - go (NPlusKPat {}) = False + do { tyth <- tcLookupGlobal dcName + ; traceTc "isIrrefutableHsPatRn dataCon" (ppr tyth) + ; case tyth of + (ATyCon tycon) -> + do { b <- foldM (\a p -> do {b <- goL p; return (a && b)}) True (hsConPatArgs details) + ; traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon + , ppr (isNewTyCon tycon) + , ppr (tcHasFixedRuntimeRep tycon)]) + ; let b' = (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon + || tcHasFixedRuntimeRep tycon) + ; return (b && b') } + id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) + (AConLike cl) -> + case cl of + RealDataCon dc -> + do let tycon = dataConTyCon dc + b <- foldM (\a p -> do {b <- goL p; return (a && b)}) + True (hsConPatArgs details) + traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon + , ppr (isNewTyCon tycon) + , ppr (tcHasFixedRuntimeRep tycon)] ) + let b' = (isJust (tyConSingleDataCon_maybe tycon) + || isNewTyCon tycon + || tcHasFixedRuntimeRep tycon) + return (b && b') + PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con) + return False -- conservative + + ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax) + } + go (LitPat {}) = do traceTc "isIrrefutableHsPatRn LitPat" empty + return False + go (NPat {}) = return False + go (NPlusKPat {}) = return False -- We conservatively assume that no TH splices are irrefutable -- since we cannot know until the splice is evaluated. - go (SplicePat {}) = False + go (SplicePat {}) = return False go (XPat ext) = case ext of - HsPatExpanded _ pat -> go pat + HsPatExpanded _ pat -> do traceTc "isIrrefutableHsPatRn HsPatEx" empty + go pat View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e9c64e654f6542aff51606a13ca866f58410755 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e9c64e654f6542aff51606a13ca866f58410755 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 02:04:47 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 22:04:47 -0400 Subject: [Git][ghc/ghc][master] docs: Remove mentions of ArrayArray# from unlifted FFI section Message-ID: <6455b5bfa4592_e3e06376f7188538954@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 1 changed file: - docs/users_guide/exts/ffi.rst Changes: ===================================== docs/users_guide/exts/ffi.rst ===================================== @@ -126,7 +126,7 @@ types may be used as arguments to FFI calls, subject to these restrictions: * Valid arguments for ``foreign import unsafe`` FFI calls: ``Array#``, - ``SmallArray#``, ``ArrayArray#``, ``ByteArray#``, and the mutable + ``SmallArray#``, ``ByteArray#``, and the mutable counterparts of these types. * Valid arguments for ``foreign import safe`` FFI calls: ``ByteArray#`` and ``MutableByteArray#``. The byte array must be @@ -174,10 +174,6 @@ are: +--------------------------------+-----------+-------------+-----------+---------------+ | ``MutableSmallArray#`` | Unsound | Unsound | Sound | Unsound | +--------------------------------+-----------+-------------+-----------+---------------+ - | ``ArrayArray#`` | Unsound | Unsound | Sound | Unsound | - +--------------------------------+-----------+-------------+-----------+---------------+ - | ``MutableArrayArray#`` | Unsound | Unsound | Sound | Unsound | - +--------------------------------+-----------+-------------+-----------+---------------+ | unpinned ``ByteArray#`` | Unsound | Unsound | Sound | Unsound | +--------------------------------+-----------+-------------+-----------+---------------+ | unpinned ``MutableByteArray#`` | Unsound | Unsound | Sound | Sound | @@ -210,32 +206,32 @@ anything from ``Rts.h``:: In other situations, the C function may need knowledge of the RTS closure types. The following example sums the first element of each ``ByteArray#`` (interpreting the bytes as an array of ``CInt``) -element of an ``ArrayArray##`` [3]_:: +element of an ``Array# ByteArray#`` [3]_:: // C source, must include the RTS to make the struct StgArrBytes - // available along with its fields: ptrs and payload. + // available along with its fields, such as `payload`. #include "Rts.h" - int sum_first (StgArrBytes **bufs) { - StgArrBytes **bufs = (StgArrBytes**)bufsTmp; + int sum_first (StgArrBytes **bufs, StgWord sz) { int res = 0; - for(StgWord ix = 0;ix < arr->ptrs;ix++) { + for(StgWord ix = 0; ix < sz; ix++) { res = res + ((int*)(bufs[ix]->payload))[0]; } return res; } - -- Haskell source, all elements in the argument array must be - -- either ByteArray# or MutableByteArray#. This is not enforced - -- by the type system in this example since ArrayArray is untyped. + -- Haskell source foreign import ccall unsafe "sum_first" - sumFirst :: ArrayArray# -> IO CInt + sumFirst :: Array# ByteArray# -> CInt -> IO CInt + + sumFirst' :: Array# ByteArray# -> IO CInt + sumFirst' arr = sumFirst arr (sizeofArray# arr) -Although GHC allows the user to pass all unlifted boxed types to -foreign functions, some of them are not amenable to useful work. -Although ``Array#`` is unlifted, the elements in its payload are -lifted, and a foreign C function cannot safely force thunks. Consequently, -a foreign C function may not dereference any of the addresses that comprise -the payload of the ``Array#``. +Although GHC allows the user to pass all unlifted boxed types to foreign +functions, some of them are not amenable to useful work. Although ``Array#`` +is unlifted, the elements in its payload can be lifted, and a foreign C +function cannot safely force thunks. Consequently, a foreign C function may not +dereference any of the addresses that comprise the payload of ``Array# a`` if +``a`` has a lifted representation. .. _ffi-newtype-io: @@ -1136,4 +1132,5 @@ byte array can be pinned as a result of three possible causes: as reading bytes from a ``MutableByteArray#``. Users should prefer ``GHC.Exts.readWord8Array#`` for this. .. [3] As in [2]_, the FFI is not actually needed for this. ``GHC.Exts`` - includes primitives for reading from on ``ArrayArray#``. + includes primitives for reading from an ``Array# a``, such as + ``GHC.Exts.indexArray#``. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f303d27dfdbf4c33af00d1a7802c8398b4a74d2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f303d27dfdbf4c33af00d1a7802c8398b4a74d2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 02:05:31 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 May 2023 22:05:31 -0400 Subject: [Git][ghc/ghc][master] Add structured error messages for GHC.Rename.Module Message-ID: <6455b5ebe9a40_e3e06392faefc54519@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 23 changed files: - compiler/GHC/Driver/Flags.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/using-warnings.rst - testsuite/tests/mdo/should_compile/mdo002.hs - testsuite/tests/polykinds/MonoidsFD.hs - testsuite/tests/polykinds/MonoidsTF.hs - testsuite/tests/profiling/should_run/T3001-2.hs - testsuite/tests/profiling/should_run/ioprof.hs - testsuite/tests/rebindable/rebindable2.hs - testsuite/tests/rebindable/rebindable2.stdout - testsuite/tests/simplCore/T9646/StrictPrim.hs - testsuite/tests/simplCore/should_run/T17744A.hs - testsuite/tests/simplCore/should_run/T3591.hs - testsuite/tests/typecheck/should_run/T1735_Help/State.hs - testsuite/tests/typecheck/should_run/T4809_IdentityT.hs - testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs - testsuite/tests/wcompat-warnings/Template.hs - testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr Changes: ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -929,6 +929,7 @@ minusWcompatOpts :: [WarningFlag] minusWcompatOpts = [ Opt_WarnSemigroup , Opt_WarnNonCanonicalMonoidInstances + , Opt_WarnNonCanonicalMonadInstances , Opt_WarnCompatUnqualifiedImports , Opt_WarnTypeEqualityOutOfScope ] ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -22,7 +22,6 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) import GHC.Hs -import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Rename.HsType @@ -452,11 +451,9 @@ checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () checkCanonicalInstances cls poly_ty mbinds = do whenWOptM Opt_WarnNonCanonicalMonadInstances $ checkCanonicalMonadInstances - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" whenWOptM Opt_WarnNonCanonicalMonoidInstances $ checkCanonicalMonoidInstances - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" where -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance @@ -472,19 +469,17 @@ checkCanonicalInstances cls poly_ty mbinds = do -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). -- - checkCanonicalMonadInstances refURL + checkCanonicalMonadInstances | cls == applicativeClassName = forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonadInstances "pure" "return" + -> addWarnNonCanonicalMonad NonCanonical_Pure | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" + -> addWarnNonCanonicalMonad NonCanonical_ThenA _ -> return () @@ -494,12 +489,10 @@ checkCanonicalInstances cls poly_ty mbinds = do FunBind { fun_id = L _ name , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonadInstances "return" "pure" + -> addWarnNonCanonicalMonad NonCanonical_Return | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" + -> addWarnNonCanonicalMonad NonCanonical_ThenM _ -> return () @@ -518,15 +511,14 @@ checkCanonicalInstances cls poly_ty mbinds = do -- -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). -- - checkCanonicalMonoidInstances refURL + checkCanonicalMonoidInstances | cls == semigroupClassName = forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" + -> addWarnNonCanonicalMonoid NonCanonical_Sappend _ -> return () @@ -536,9 +528,7 @@ checkCanonicalInstances cls poly_ty mbinds = do FunBind { fun_id = L _ name , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonoidInstances - "mappend" "(<>)" + -> addWarnNonCanonicalMonoid NonCanonical_Mappend _ -> return () @@ -554,51 +544,14 @@ checkCanonicalInstances cls poly_ty mbinds = do , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing - -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 refURL flag lhs rhs = do - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints $ - vcat [ text "Noncanonical" <+> - quotes (text (lhs ++ " = " ++ rhs)) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Move definition from" <+> - quotes (text rhs) <+> - text "to" <+> quotes (text lhs) - , text "See also:" <+> - text refURL - ] - addDiagnostic dia - - -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 refURL flag lhs rhs = do - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints $ - vcat [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , quotes (text lhs) <+> - text "will eventually be removed in favour of" <+> - quotes (text rhs) - , text "Either remove definition for" <+> - quotes (text lhs) <+> text "(recommended)" <+> - text "or define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - , text "See also:" <+> - text refURL - ] - addDiagnostic dia - - -- stolen from GHC.Tc.TyCl.Instance - instDeclCtxt1 :: LHsSigType GhcRn -> SDoc - instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - - inst_decl_ctxt :: SDoc -> SDoc - inst_decl_ctxt doc = hang (text "in the instance declaration for") - 2 (quotes doc <> text ".") + addWarnNonCanonicalMonoid reason = + addWarnNonCanonicalDefinition (NonCanonicalMonoid reason) + addWarnNonCanonicalMonad reason = + addWarnNonCanonicalDefinition (NonCanonicalMonad reason) + + addWarnNonCanonicalDefinition reason = + addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty) rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -1859,6 +1859,9 @@ instance Diagnostic TcRnMessage where locations = text "Bound at:" <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs))) + TcRnNonCanonicalDefinition reason inst_ty + -> mkSimpleDecorated $ + pprNonCanonicalDefinition inst_ty reason diagnosticReason = \case TcRnUnknownMessage m @@ -2484,6 +2487,11 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnBindingNameConflict{} -> ErrorWithoutFlag + TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _ + -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances + TcRnNonCanonicalDefinition (NonCanonicalMonad _) _ + -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances + diagnosticHints = \case TcRnUnknownMessage m @@ -3145,6 +3153,8 @@ instance Diagnostic TcRnMessage where -> noHints TcRnBindingNameConflict{} -> noHints + TcRnNonCanonicalDefinition reason _ + -> suggestNonCanonicalDefinition reason diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode diagnosticCode = constructorCode @@ -5451,3 +5461,78 @@ pprAmbiguousGreName gre | otherwise = pprPanic "addNameClassErrRn" (ppr gre) -- Invariant: either 'lcl' is True or 'iss' is non-empty + +pprNonCanonicalDefinition :: LHsSigType GhcRn + -> NonCanonicalDefinition + -> SDoc +pprNonCanonicalDefinition inst_ty = \case + NonCanonicalMonoid sub -> case sub of + NonCanonical_Sappend -> + msg1 "(<>)" "mappend" + NonCanonical_Mappend -> + msg2 "mappend" "(<>)" + NonCanonicalMonad sub -> case sub of + NonCanonical_Pure -> + msg1 "pure" "return" + NonCanonical_ThenA -> + msg1 "(*>)" "(>>)" + NonCanonical_Return -> + msg2 "return" "pure" + NonCanonical_ThenM -> + msg2 "(>>)" "(*>)" + where + msg1 :: String -> String -> SDoc + msg1 lhs rhs = + vcat [ text "Noncanonical" <+> + quotes (text (lhs ++ " = " ++ rhs)) <+> + text "definition detected" + , inst + ] + + msg2 :: String -> String -> SDoc + msg2 lhs rhs = + vcat [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , inst + , quotes (text lhs) <+> + text "will eventually be removed in favour of" <+> + quotes (text rhs) + ] + + inst = instDeclCtxt1 inst_ty + + -- stolen from GHC.Tc.TyCl.Instance + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc + instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + + inst_decl_ctxt :: SDoc -> SDoc + inst_decl_ctxt doc = hang (text "in the instance declaration for") + 2 (quotes doc <> text ".") + +suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint] +suggestNonCanonicalDefinition reason = + [action doc] + where + action = case reason of + NonCanonicalMonoid sub -> case sub of + NonCanonical_Sappend -> move sappendName mappendName + NonCanonical_Mappend -> remove mappendName sappendName + NonCanonicalMonad sub -> case sub of + NonCanonical_Pure -> move pureAName returnMName + NonCanonical_ThenA -> move thenAName thenMName + NonCanonical_Return -> remove returnMName pureAName + NonCanonical_ThenM -> remove thenMName thenAName + + move = SuggestMoveNonCanonicalDefinition + remove = SuggestRemoveNonCanonicalDefinition + + doc = case reason of + NonCanonicalMonoid _ -> doc_monoid + NonCanonicalMonad _ -> doc_monad + + doc_monoid = + "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" + doc_monad = + "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -116,6 +116,9 @@ module GHC.Tc.Errors.Types ( , UnusedImportName (..) , NestedForallsContextsIn(..) , UnusedNameProv(..) + , NonCanonicalDefinition(..) + , NonCanonical_Monoid(..) + , NonCanonical_Monad(..) ) where import GHC.Prelude @@ -4037,6 +4040,19 @@ data TcRnMessage where -- ^ The locations of the duplicates -> TcRnMessage + {-| TcRnNonCanonicalDefinition is a warning indicating that an instance + defines an implementation for a method that should not be defined in a way + that deviates from its default implementation, for example because it has + been scheduled to be absorbed into another method, like @pure@ making + @return@ obsolete. + + Test cases: + WCompatWarningsOn, WCompatWarningsOff, WCompatWarningsOnOff + -} + TcRnNonCanonicalDefinition :: !NonCanonicalDefinition -- ^ Specifics + -> !(LHsSigType GhcRn) -- ^ The instance type + -> TcRnMessage + deriving Generic -- | Things forbidden in @type data@ declarations. @@ -5567,3 +5583,34 @@ data UnusedNameProv | UnusedNameTypePattern | UnusedNameMatch | UnusedNameLocalBind + +-- | Different reasons for TcRnNonCanonicalDefinition. +data NonCanonicalDefinition = + -- | Related to @(<>)@ and @mappend at . + NonCanonicalMonoid NonCanonical_Monoid + | + -- | Related to @(*>)@/@(>>)@ and @pure@/@return at . + NonCanonicalMonad NonCanonical_Monad + deriving (Generic) + +-- | Possible cases for the -Wnoncanonical-monoid-instances. +data NonCanonical_Monoid = + -- | @(<>) = mappend@ was defined. + NonCanonical_Sappend + | + -- | @mappend@ was defined as something other than @(<>)@. + NonCanonical_Mappend + +-- | Possible cases for the -Wnoncanonical-monad-instances. +data NonCanonical_Monad = + -- | @pure = return@ was defined. + NonCanonical_Pure + | + -- | @(*>) = (>>)@ was defined. + NonCanonical_ThenA + | + -- | @return@ was defined as something other than @pure at . + NonCanonical_Return + | + -- | @(>>)@ was defined as something other than @(*>)@. + NonCanonical_ThenM ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -598,6 +598,8 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnIllegalInferredTyVars" = 54832 GhcDiagnosticCode "TcRnAmbiguousName" = 87543 GhcDiagnosticCode "TcRnBindingNameConflict" = 10498 + GhcDiagnosticCode "NonCanonicalMonoid" = 50928 + GhcDiagnosticCode "NonCanonicalMonad" = 22705 -- PatSynInvalidRhsReason GhcDiagnosticCode "PatSynNotInvertible" = 69317 @@ -856,6 +858,7 @@ type family ConRecursInto con where ConRecursInto "DodgyImportsHiding" = 'Just ImportLookupReason ConRecursInto "TcRnImportLookup" = 'Just ImportLookupReason ConRecursInto "TcRnUnusedImport" = 'Just UnusedImportReason + ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition -- -- TH errors ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -438,6 +438,21 @@ data GhcHint bind anything useful. -} | SuggestRemoveRecordWildcard + {-| Suggest moving a method implementation to a different instance to its + superclass that defines the canonical version of the method. + -} + | SuggestMoveNonCanonicalDefinition + Name -- ^ move the implementation from this method + Name -- ^ ... to this method + String -- ^ Documentation URL + + {-| Suggest removing a method implementation when a superclass defines the + canonical version of that method. + -} + | SuggestRemoveNonCanonicalDefinition + Name -- ^ method with non-canonical implementation + Name -- ^ possible other method to use as the RHS instead + String -- ^ Documentation URL -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -234,6 +234,17 @@ instance Outputable GhcHint where -> text "Enable Safe Haskell through either Safe, Trustworthy or Unsafe." SuggestRemoveRecordWildcard -> text "Omit the" <+> quotes (text "..") + SuggestMoveNonCanonicalDefinition lhs rhs refURL -> + text "Move definition from" <+> + quotes (pprPrefixUnqual rhs) <+> + text "to" <+> quotes (pprPrefixUnqual lhs) $$ + text "See also:" <+> text refURL + SuggestRemoveNonCanonicalDefinition lhs rhs refURL -> + text "Either remove definition for" <+> + quotes (pprPrefixUnqual lhs) <+> text "(recommended)" <+> + text "or define as" <+> + quotes (pprPrefixUnqual lhs <+> text "=" <+> pprPrefixUnqual rhs) $$ + text "See also:" <+> text refURL perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" @@ -343,3 +354,7 @@ pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope) pp_ns rdr | ns /= tried_ns = pprNameSpace ns | otherwise = empty where ns = rdrNameSpace rdr + +pprPrefixUnqual :: Name -> SDoc +pprPrefixUnqual name = + pprPrefixOcc (getOccName name) ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -163,6 +163,7 @@ as ``-Wno-...`` for every individual warning in the group. * :ghc-flag:`-Wsemigroup` * :ghc-flag:`-Wnoncanonical-monoid-instances` + * :ghc-flag:`-Wnoncanonical-monad-instances` * :ghc-flag:`-Wcompat-unqualified-imports` * :ghc-flag:`-Wtype-equality-out-of-scope` @@ -566,7 +567,7 @@ of ``-W(no-)*``. :since: 8.0 - :default: off + :default: on Warn if noncanonical ``Applicative`` or ``Monad`` instances declarations are detected. @@ -584,6 +585,8 @@ of ``-W(no-)*``. * Warn if ``pure`` is defined backwards (i.e. ``pure = return``). * Warn if ``(*>)`` is defined backwards (i.e. ``(*>) = (>>)``). + This warning is part of the :ghc-flag:`-Wcompat` option group. + .. ghc-flag:: -Wnoncanonical-monadfail-instances :shortdesc: *(deprecated)* warn when ``Monad`` or ``MonadFail`` instances have @@ -610,6 +613,8 @@ of ``-W(no-)*``. :since: 8.0 + :default: on + Warn if noncanonical ``Semigroup`` or ``Monoid`` instances declarations are detected. @@ -625,8 +630,7 @@ of ``-W(no-)*``. * Warn if ``(<>)`` is defined backwards (i.e. ``(<>) = mappend``). - This warning is off by default. However, it is part of the - :ghc-flag:`-Wcompat` option group. + This warning is part of the :ghc-flag:`-Wcompat` option group. .. ghc-flag:: -Wmissing-monadfail-instances :shortdesc: *(deprecated)* ===================================== testsuite/tests/mdo/should_compile/mdo002.hs ===================================== @@ -13,11 +13,10 @@ instance Functor X where fmap f (X a) = X (f a) instance Applicative X where - pure = return + pure = X (<*>) = ap instance Monad X where - return = X (X a) >>= f = f a instance MonadFix X where ===================================== testsuite/tests/polykinds/MonoidsFD.hs ===================================== @@ -25,7 +25,7 @@ class Monoidy to comp id m | m to → comp id where -- We use functional dependencies to help the typechecker understand that -- m and ~> uniquely determine comp (times) and id. --- +-- -- This kind of type class would not have been possible in previous -- versions of GHC; with the new kind system, however, we can abstract -- over kinds!2 Now, let’s create types for the additive and @@ -89,18 +89,17 @@ instance Monoidy (→) (,) () m ⇒ Monoid m where mempty = munit () instance Applicative Wrapper where - pure = return + pure x = runNT munit $ Id x (<*>) = ap -- instance (Functor m, Monoidy NT FC Id m) ⇒ Monad m where instance Monad Wrapper where - return x = runNT munit $ Id x x >>= f = runNT mjoin $ FC (f `fmap` x) -- And so the following works: test3 - = do { print (mappend mempty (Sum 2)) + = do { print (mappend mempty (Sum 2)) -- Sum 2 ; print (mappend (Product 2) (Product 3)) -- Product 6 ===================================== testsuite/tests/polykinds/MonoidsTF.hs ===================================== @@ -103,11 +103,10 @@ instance (MId (→) m ~ (), MComp (→) m ~ (,), Monoidy (→) m) mempty = munit () instance Applicative Wrapper where - pure = return + pure x = runNT munit $ Id x (<*>) = ap instance Monad Wrapper where - return x = runNT munit $ Id x x >>= f = runNT mjoin $ FC (f `fmap` x) -- And so the following works: ===================================== testsuite/tests/profiling/should_run/T3001-2.hs ===================================== @@ -90,22 +90,20 @@ instance Functor PutM where fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w instance Monad PutM where - return a = Put $ PairS a mempty - m >>= k = Put $ let PairS a w = unPut m PairS b w' = unPut (k a) in PairS b (w `mappend` w') - m >> k = Put $ +instance Applicative PutM where + pure a = Put $ PairS a mempty + (<*>) = ap + + m *> k = Put $ let PairS _ w = unPut m PairS b w' = unPut k in PairS b (w `mappend` w') -instance Applicative PutM where - pure = return - (<*>) = ap - tell :: Builder -> Put tell b = Put $ PairS () b @@ -189,9 +187,6 @@ joinZ bb lb | otherwise = L.Chunk bb lb instance Monad Get where - return a = Get (\s -> (a, s)) - {-# INLINE return #-} - m >>= k = Get (\s -> let (a, s') = unGet m s in unGet (k a) s') {-# INLINE (>>=) #-} @@ -200,7 +195,9 @@ instance MonadFail Get where fail = error "failDesc" instance Applicative Get where - pure = return + pure a = Get (\s -> (a, s)) + {-# INLINE pure #-} + (<*>) = ap getZ :: Get S ===================================== testsuite/tests/profiling/should_run/ioprof.hs ===================================== @@ -10,13 +10,13 @@ newtype M s a = M { unM :: s -> (s,a) } instance Monad (M s) where (M m) >>= k = M $ \s -> case m s of (s',a) -> unM (k a) s' - return a = M $ \s -> (s,a) + instance Functor (M s) where fmap = liftM instance Applicative (M s) where - pure = return + pure a = M $ \s -> (s,a) (<*>) = ap errorM :: String -> M s a ===================================== testsuite/tests/rebindable/rebindable2.hs ===================================== @@ -24,16 +24,15 @@ module Main where }; instance (Applicative TM) where { - pure = return; + pure a = MkTM (debugFunc "pure" (Prelude.pure a)); + (*>) ma mb = MkTM (debugFunc "*>" ((Prelude.*>) (unTM ma) (unTM mb))); (<*>) = ap; }; instance (Monad TM) where { - return a = MkTM (debugFunc "return" (Prelude.return a)); - + return = pure; (>>=) ma amb = MkTM (debugFunc ">>=" ((Prelude.>>=) (unTM ma) (\a -> unTM (amb a)))); - - (>>) ma mb = MkTM (debugFunc ">>" ((Prelude.>>) (unTM ma) (unTM mb))); + (>>) = (*>) }; instance (MonadFail TM) where { ===================================== testsuite/tests/rebindable/rebindable2.stdout ===================================== @@ -1,18 +1,18 @@ start test test_do failure -++ >> +++ *> ++ >>= ++ fail -- fail -- >>= --- >> +-- *> end test test_do failure start test test_do success -++ >> +++ *> ++ >>= -++ return --- return +++ pure +-- pure -- >>= --- >> +-- *> end test test_do success start test test_fromInteger 135 ===================================== testsuite/tests/simplCore/T9646/StrictPrim.hs ===================================== @@ -18,7 +18,10 @@ newtype StrictPrim s a instance Applicative (StrictPrim s) where {-# INLINE pure #-} - pure = return + pure !x = StrictPrim ( \ !s -> (# s, x #)) + + {-# INLINE (*>) #-} + (!m) *> (!k) = do { _ <- m ; k } {-# INLINE (<*>) #-} (<*>) a b = do f <- a ; v <- b ; return $! (f $! v) @@ -31,11 +34,6 @@ instance Functor (StrictPrim s) where instance Monad (StrictPrim s) where - {-# INLINE return #-} - return !x = StrictPrim ( \ !s -> (# s, x #)) - - {-# INLINE (>>) #-} - (!m) >> (!k) = do { _ <- m ; k } {-# INLINE (>>=) #-} (StrictPrim !m) >>= (!k) = ===================================== testsuite/tests/simplCore/should_run/T17744A.hs ===================================== @@ -17,10 +17,9 @@ instance Functor (Parser t) where fmap f p = apply (fmap f) p instance Applicative (Parser t) where - pure = return + pure = Result mempty instance Monad (Parser t) where - return = Result mempty Result s r >>= f = feed s (f r) p >>= f = apply (>>= f) p ===================================== testsuite/tests/simplCore/should_run/T3591.hs ===================================== @@ -1,4 +1,4 @@ -{- +{- Copyright 2009 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -20,7 +20,7 @@ -- | Module "Trampoline" defines the pipe computations and their basic building blocks. {-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, - TypeFamilies, KindSignatures, FlexibleContexts, + TypeFamilies, KindSignatures, FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances #-} @@ -75,11 +75,10 @@ instance Functor Identity where fmap = liftM instance Applicative Identity where - pure = return + pure a = Identity a (<*>) = ap instance Monad Identity where - return a = Identity a m >>= k = k (runIdentity m) newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)} @@ -89,11 +88,10 @@ instance (Monad m, Functor s) => Functor (Trampoline m s) where fmap = liftM instance (Monad m, Functor s) => Applicative (Trampoline m s) where - pure = return + pure x = Trampoline (return (Done x)) (<*>) = ap instance (Monad m, Functor s) => Monad (Trampoline m s) where - return x = Trampoline (return (Done x)) t >>= f = Trampoline (bounce t >>= apply f) where apply f (Done x) = bounce (f x) apply f (Suspend s) = return (Suspend (fmap (>>= f) s)) @@ -111,7 +109,7 @@ instance Functor (Await x) where data EitherFunctor l r x = LeftF (l x) | RightF (r x) instance (Functor l, Functor r) => Functor (EitherFunctor l r) where - fmap f v = trace "fmap Either" $ + fmap f v = trace "fmap Either" $ case v of LeftF l -> trace "fmap LeftF" $ LeftF (fmap f l) RightF r -> trace "fmap RightF" $ RightF (fmap f r) @@ -178,7 +176,7 @@ liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoli liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma) where inject :: TrampolineState m a x -> TrampolineState m d x inject (Done x) = Done x - inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $ + inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $ fmap liftOut (trace "poking a" a)) data Sink (m :: Type -> Type) a x = ===================================== testsuite/tests/typecheck/should_run/T1735_Help/State.hs ===================================== @@ -7,7 +7,6 @@ import Control.Monad (ap, liftM) newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } instance Monad m => Monad (StateT s m) where - return a = StateT $ \s -> return (a, s) m >>= k = StateT $ \s -> do ~(a, s') <- runStateT m s runStateT (k a) s' @@ -19,7 +18,7 @@ instance Monad m => Functor (StateT s m) where fmap = liftM instance Monad m => Applicative (StateT s m) where - pure = return + pure a = StateT $ \s -> pure (a, s) (<*>) = ap get :: Monad m => StateT s m s ===================================== testsuite/tests/typecheck/should_run/T4809_IdentityT.hs ===================================== @@ -19,9 +19,8 @@ data XML -- * IdentityT Monad Transformer newtype IdentityT m a = IdentityT { runIdentityT :: m a } - deriving (Functor, Monad, MonadIO, MonadPlus) + deriving (Functor, Applicative, Monad, MonadIO, MonadPlus) -instance Monad m => Applicative (IdentityT m) where instance Monad m => Alternative (IdentityT m) where instance MonadTrans IdentityT where ===================================== testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs ===================================== @@ -34,12 +34,9 @@ import Control.Monad (MonadPlus(..),liftM) -- | The monad transformer that allows a monad to generate XML values. newtype XMLGenT m a = XMLGenT (m a) - deriving (Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r, - MonadState s, MonadRWS r w s, MonadCont, MonadError e) - -instance Monad m => Applicative (XMLGenT m) where - pure = return - (<*>) = ap + deriving (Monad, Functor, Applicative, MonadIO, MonadPlus, MonadWriter w, + MonadReader r, MonadState s, MonadRWS r w s, MonadCont, + MonadError e) instance Monad m => Alternative (XMLGenT m) where ===================================== testsuite/tests/wcompat-warnings/Template.hs ===================================== @@ -13,3 +13,18 @@ instance Semi.Semigroup S where instance Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 + +newtype M a = M a + +instance Functor M where + fmap = undefined + +instance Applicative M where + liftA2 = undefined + pure = return + (*>) = (>>) + +instance Monad M where + return = undefined + (>>=) = undefined + (>>) = undefined ===================================== testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr ===================================== @@ -3,15 +3,47 @@ Template.hs:5:1: warning: [-Wsemigroup (in -Wcompat)] Local definition of ‘<>’ clashes with a future Prelude name. This will become an error in a future release. -Template.hs:11:3: warning: [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] +Template.hs:11:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] Noncanonical ‘(<>) = mappend’ definition detected in the instance declaration for ‘Semigroup S’. - Move definition from ‘mappend’ to ‘(<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + Suggested fix: + Move definition from ‘mappend’ to ‘(<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid -Template.hs:14:3: warning: [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] +Template.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] Noncanonical ‘mappend’ definition detected in the instance declaration for ‘Monoid S’. ‘mappend’ will eventually be removed in favour of ‘(<>)’ - Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + Suggested fix: + Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + +Template.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] + Noncanonical ‘pure = return’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘return’ to ‘pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +Template.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] + Noncanonical ‘(*>) = (>>)’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘(>>)’ to ‘(*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +Template.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] + Noncanonical ‘return’ definition detected + in the instance declaration for ‘Monad M’. + ‘return’ will eventually be removed in favour of ‘pure’ + Suggested fix: + Either remove definition for ‘return’ (recommended) or define as ‘return = pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +Template.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] + Noncanonical ‘(>>)’ definition detected + in the instance declaration for ‘Monad M’. + ‘(>>)’ will eventually be removed in favour of ‘(*>)’ + Suggested fix: + Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/994bda563604461ffb8454d6e298b0310520bcc8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/994bda563604461ffb8454d6e298b0310520bcc8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 04:08:02 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Sat, 06 May 2023 00:08:02 -0400 Subject: [Git][ghc/ghc][wip/expand-do] something good in sight Message-ID: <6455d2a2e4c71_e3e0631942c185457af@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 69fa92cb by Apoorv Ingle at 2023-05-05T23:07:55-05:00 something good in sight - - - - - 3 changed files: - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/HsToCore/Docs.hs ===================================== @@ -346,10 +346,10 @@ subordinates env instMap decl = case decl of data_fams = do DataFamInstDecl { dfid_eqn = (FamEqn { feqn_tycon = L l _ - , feqn_rhs = defn } :: FamEqn GhcRn (HsDataDefn GhcRn))} <- unLoc <$> cid_datafam_insts d + , feqn_rhs = defn })} <- unLoc <$> cid_datafam_insts d [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn ty_fams = do - TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ } :: FamEqn GhcRn (LHsType GhcRn)) } <- unLoc <$> cid_tyfam_insts d + TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ }) } <- unLoc <$> cid_tyfam_insts d [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] in data_fams ++ ty_fams ===================================== compiler/GHC/HsToCore/Pmc/Utils.hs ===================================== @@ -108,8 +108,8 @@ arrowMatchContextExhaustiveWarningFlag = \ case -- 'HsMatchContext' (does not matter whether it is the redundancy check or the -- exhaustiveness check). isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool -isMatchContextPmChecked _ origin LambdaExpr -- It is likely that this is generated by expanding do stmts - = isGenerated origin +-- isMatchContextPmChecked _ origin LambdaExpr -- It is likely that this is generated by expanding do stmts +-- = isGenerated origin isMatchContextPmChecked dflags origin kind | isGenerated origin = False ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1623,8 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs -- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on type checking +-- does depend on the type environment however isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> TcM Bool -isIrrefutableHsPatRn _ is_strict pat = +isIrrefutableHsPatRn tc_env is_strict pat = do traceTc "isIrrefutableHsPatRn" empty goL pat where @@ -1662,9 +1663,7 @@ isIrrefutableHsPatRn _ is_strict pat = ; traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon , ppr (isNewTyCon tycon) , ppr (tcHasFixedRuntimeRep tycon)]) - ; let b' = (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon - || tcHasFixedRuntimeRep tycon) + ; let b' = isJust (tyConSingleDataCon_maybe tycon) ; return (b && b') } id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) (AConLike cl) -> @@ -1676,9 +1675,7 @@ isIrrefutableHsPatRn _ is_strict pat = traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon , ppr (isNewTyCon tycon) , ppr (tcHasFixedRuntimeRep tycon)] ) - let b' = (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon - || tcHasFixedRuntimeRep tycon) + let b' = isJust (tyConSingleDataCon_maybe tycon) return (b && b') PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con) return False -- conservative View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69fa92cb1ec0c366ca13046697019123e2b9673a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69fa92cb1ec0c366ca13046697019123e2b9673a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 11:21:08 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Sat, 06 May 2023 07:21:08 -0400 Subject: [Git][ghc/ghc][wip/decode_cloned_stack] Remove duplicated code in Printer.c (rebase fixup) Message-ID: <64563824d56d1_e3e064858a23057209a@gitlab.mail> Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC Commits: 31d6f67b by Sven Tennie at 2023-05-06T11:20:11+00:00 Remove duplicated code in Printer.c (rebase fixup) - - - - - 1 changed file: - rts/Printer.c Changes: ===================================== rts/Printer.c ===================================== @@ -279,6 +279,24 @@ printClosure( const StgClosure *obj ) break; } + case UNDERFLOW_FRAME: + { + StgUnderflowFrame* u = (StgUnderflowFrame*)obj; + debugBelch("UNDERFLOW_FRAME("); + printPtr((StgPtr)u->next_chunk); + debugBelch(")\n"); + break; + } + + case STOP_FRAME: + { + StgStopFrame* u = (StgStopFrame*)obj; + debugBelch("STOP_FRAME("); + printPtr((StgPtr)GET_INFO((StgClosure *)u)); + debugBelch(")\n"); + break; + } + case CATCH_RETRY_FRAME: { StgCatchRetryFrame* frame = (StgCatchRetryFrame*)obj; @@ -318,63 +336,6 @@ printClosure( const StgClosure *obj ) break; } - case UNDERFLOW_FRAME: - { - StgUnderflowFrame* u = (StgUnderflowFrame*)obj; - debugBelch("UNDERFLOW_FRAME("); - printPtr((StgPtr)u->next_chunk); - debugBelch(")\n"); - break; - } - - case STOP_FRAME: - { - StgStopFrame* u = (StgStopFrame*)obj; - debugBelch("STOP_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); - debugBelch(")\n"); - break; - } - - case ATOMICALLY_FRAME: - { - StgAtomicallyFrame* u = (StgAtomicallyFrame*)obj; - debugBelch("ATOMICALLY_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); - debugBelch(","); - printPtr((StgPtr)u->code); - debugBelch(","); - printPtr((StgPtr)u->result); - debugBelch(")\n"); - break; - } - - case CATCH_RETRY_FRAME: - { - StgCatchRetryFrame* u = (StgCatchRetryFrame*)obj; - debugBelch("CATCH_RETRY_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); - debugBelch(","); - printPtr((StgPtr)u->first_code); - debugBelch(","); - printPtr((StgPtr)u->alt_code); - debugBelch(")\n"); - break; - } - - case CATCH_STM_FRAME: - { - StgCatchSTMFrame* u = (StgCatchSTMFrame*)obj; - debugBelch("CATCH_STM_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); - debugBelch(","); - printPtr((StgPtr)u->code); - debugBelch(","); - printPtr((StgPtr)u->handler); - debugBelch(")\n"); - break; - } - case ARR_WORDS: { StgWord i; @@ -618,9 +579,6 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) case UPDATE_FRAME: case CATCH_FRAME: - case CATCH_RETRY_FRAME: - case CATCH_STM_FRAME: - case ATOMICALLY_FRAME: case UNDERFLOW_FRAME: case STOP_FRAME: case ATOMICALLY_FRAME: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31d6f67b093b1e2e34496e0dc71e12cfcce7efe5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31d6f67b093b1e2e34496e0dc71e12cfcce7efe5 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 11:25:46 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Sat, 06 May 2023 07:25:46 -0400 Subject: [Git][ghc/ghc][wip/decode_cloned_stack] Printer.c: Smaller diff + correct cast Message-ID: <6456393ac0677_e3e06485f0dc857259f@gitlab.mail> Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC Commits: a661ec56 by Sven Tennie at 2023-05-06T11:25:22+00:00 Printer.c: Smaller diff + correct cast - - - - - 1 changed file: - rts/Printer.c Changes: ===================================== rts/Printer.c ===================================== @@ -296,7 +296,20 @@ printClosure( const StgClosure *obj ) debugBelch(")\n"); break; } - + + case ATOMICALLY_FRAME: + { + StgAtomicallyFrame* frame = (StgAtomicallyFrame*)obj; + debugBelch("ATOMICALLY_FRAME("); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); + debugBelch(","); + printPtr((StgPtr)frame->code); + debugBelch(","); + printPtr((StgPtr)frame->result); + debugBelch(")\n"); + break; + } + case CATCH_RETRY_FRAME: { StgCatchRetryFrame* frame = (StgCatchRetryFrame*)obj; @@ -323,19 +336,6 @@ printClosure( const StgClosure *obj ) break; } - case ATOMICALLY_FRAME: - { - StgAtomicallyFrame* frame = (StgAtomicallyFrame*)obj; - debugBelch("ATOMICALLY_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)frame)); - debugBelch(","); - printPtr((StgPtr)frame->code); - debugBelch(","); - printPtr((StgPtr)frame->result); - debugBelch(")\n"); - break; - } - case ARR_WORDS: { StgWord i; @@ -715,17 +715,17 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type); switch (fun_info->f.fun_type) { case ARG_GEN: - printSmallBitmap(spBottom, &ret_fun->payload, + printSmallBitmap(spBottom, (StgPtr) &ret_fun->payload, BITMAP_BITS(fun_info->f.b.bitmap), BITMAP_SIZE(fun_info->f.b.bitmap)); break; case ARG_GEN_BIG: - printLargeBitmap(spBottom, &ret_fun->payload, + printLargeBitmap(spBottom, (StgPtr) &ret_fun->payload, GET_FUN_LARGE_BITMAP(fun_info), GET_FUN_LARGE_BITMAP(fun_info)->size); break; default: - printSmallBitmap(spBottom, &ret_fun->payload, + printSmallBitmap(spBottom, (StgPtr) &ret_fun->payload, BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]), BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type])); break; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a661ec564e5bab4c0cadb1af9ba2566b9b610df3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a661ec564e5bab4c0cadb1af9ba2566b9b610df3 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat May 6 17:50:08 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Sat, 06 May 2023 13:50:08 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/T23070-pipeline-monad Message-ID: <64569350c3ce8_e3e06556bf76060142a@gitlab.mail> Simon Peyton Jones pushed new branch wip/T23070-pipeline-monad at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T23070-pipeline-monad You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun May 7 08:11:09 2023 From: gitlab at gitlab.haskell.org (Adam Gundry (@adamgundry)) Date: Sun, 07 May 2023 04:11:09 -0400 Subject: [Git][ghc/ghc][wip/amg/tweak-co-opt] 997 commits: Introduce a standard thunk for allocating strings Message-ID: <64575d1d75820_e3e0661cb56186560f2@gitlab.mail> Adam Gundry pushed to branch wip/amg/tweak-co-opt at Glasgow Haskell Compiler / GHC Commits: 86e6549e by Ömer Sinan Ağacan at 2022-10-22T07:41:30-04:00 Introduce a standard thunk for allocating strings Currently for a top-level closure in the form hey = unpackCString# x we generate code like this: Main.hey_entry() // [R1] { info_tbls: [(c2T4, label: Main.hey_info rep: HeapRep static { Thunk } srt: Nothing)] stack_info: arg_space: 8 updfr_space: Just 8 } {offset c2T4: // global _rqm::P64 = R1; if ((Sp + 8) - 24 < SpLim) (likely: False) goto c2T5; else goto c2T6; c2T5: // global R1 = _rqm::P64; call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8; c2T6: // global (_c2T1::I64) = call "ccall" arg hints: [PtrHint, PtrHint] result hints: [PtrHint] newCAF(BaseReg, _rqm::P64); if (_c2T1::I64 == 0) goto c2T3; else goto c2T2; c2T3: // global call (I64[_rqm::P64])() args: 8, res: 0, upd: 8; c2T2: // global I64[Sp - 16] = stg_bh_upd_frame_info; I64[Sp - 8] = _c2T1::I64; R2 = hey1_r2Gg_bytes; Sp = Sp - 16; call GHC.CString.unpackCString#_info(R2) args: 24, res: 0, upd: 24; } } This code is generated for every string literal. Only difference between top-level closures like this is the argument for the bytes of the string (hey1_r2Gg_bytes in the code above). With this patch we introduce a standard thunk in the RTS, called stg_MK_STRING_info, that does what `unpackCString# x` does, except it gets the bytes address from the payload. Using this, for the closure above, we generate this: Main.hey_closure" { Main.hey_closure: const stg_MK_STRING_info; const 0; // padding for indirectee const 0; // static link const 0; // saved info const hey1_r1Gg_bytes; // the payload } This is much smaller in code. Metric Decrease: T10421 T11195 T12150 T12425 T16577 T18282 T18698a T18698b Co-Authored By: Ben Gamari <ben at well-typed.com> - - - - - 1937016b by Andreas Klebinger at 2022-10-22T07:42:06-04:00 hadrian: Improve error for wrong key/value errors. - - - - - 11fe42d8 by Vladislav Zavialov at 2022-10-23T00:11:50+03:00 Class layout info (#19623) Updates the haddock submodule. - - - - - f0a90c11 by Sven Tennie at 2022-10-24T00:12:51-04:00 Pin used way for test cloneMyStack (#21977) cloneMyStack checks the order of closures on the cloned stack. This may change for different ways. Thus we limit this test to one way (normal). - - - - - 0614e74d by Aaron Allen at 2022-10-24T17:11:21+02:00 Convert Diagnostics in GHC.Tc.Gen.Splice (#20116) Replaces uses of `TcRnUnknownMessage` in `GHC.Tc.Gen.Splice` with structured diagnostics. closes #20116 - - - - - 8d2dbe2d by Andreas Klebinger at 2022-10-24T15:59:41-04:00 Improve stg lint for unboxed sums. It now properly lints cases where sums end up distributed over multiple args after unarise. Fixes #22026. - - - - - 41406da5 by Simon Peyton Jones at 2022-10-25T18:07:03-04:00 Fix binder-swap bug This patch fixes #21229 properly, by avoiding doing a binder-swap on dictionary Ids. This is pretty subtle, and explained in Note [Care with binder-swap on dictionaries]. Test is already in simplCore/should_run/T21229 This allows us to restore a feature to the specialiser that we had to revert: see Note [Specialising polymorphic dictionaries]. (This is done in a separate patch.) I also modularised things, using a new function scrutBinderSwap_maybe in all the places where we are (effectively) doing a binder-swap, notably * Simplify.Iteration.addAltUnfoldings * SpecConstr.extendCaseBndrs In Simplify.Iteration.addAltUnfoldings I also eliminated a guard Many <- idMult case_bndr because we concluded, in #22123, that it was doing no good. - - - - - 5a997e16 by Simon Peyton Jones at 2022-10-25T18:07:03-04:00 Make the specialiser handle polymorphic specialisation Ticket #13873 unexpectedly showed that a SPECIALISE pragma made a program run (a lot) slower, because less specialisation took place overall. It turned out that the specialiser was missing opportunities because of quantified type variables. It was quite easy to fix. The story is given in Note [Specialising polymorphic dictionaries] Two other minor fixes in the specialiser * There is no benefit in specialising data constructor /wrappers/. (They can appear overloaded because they are given a dictionary to store in the constructor.) Small guard in canSpecImport. * There was a buglet in the UnspecArg case of specHeader, in the case where there is a dead binder. We need a LitRubbish filler for the specUnfolding stuff. I expanded Note [Drop dead args from specialisations] to explain. There is a 4% increase in compile time for T15164, because we generate more specialised code. This seems OK. Metric Increase: T15164 - - - - - 7f203d00 by Sylvain Henry at 2022-10-25T18:07:43-04:00 Numeric exceptions: replace FFI calls with primops ghc-bignum needs a way to raise numerical exceptions defined in base package. At the time we used FFI calls into primops defined in the RTS. These FFI calls had to be wrapped into hacky bottoming functions because "foreign import prim" syntax doesn't support giving a bottoming demand to the foreign call (cf #16929). These hacky wrapper functions trip up the JavaScript backend (#21078) because they are polymorphic in their return type. This commit replaces them with primops very similar to raise# but raising predefined exceptions. - - - - - 0988a23d by Sylvain Henry at 2022-10-25T18:08:24-04:00 Enable popcount rewrite rule when cross-compiling The comment applies only when host's word size < target's word size. So we can relax the guard. - - - - - a2f53ac8 by Sylvain Henry at 2022-10-25T18:09:05-04:00 Add GHC.SysTools.Cpp module Move doCpp out of the driver to be able to use it in the upcoming JS backend. - - - - - 1fd7f201 by Ben Gamari at 2022-10-25T18:09:42-04:00 llvm-targets: Add datalayouts for big-endian AArch64 targets Fixes #22311. Thanks to @zeldin for the patch. - - - - - f5a486eb by Krzysztof Gogolewski at 2022-10-25T18:10:19-04:00 Cleanup String/FastString conversions Remove unused mkPtrString and isUnderscoreFS. We no longer use mkPtrString since 1d03d8bef96. Remove unnecessary conversions between FastString and String and back. - - - - - f7bfb40c by Ryan Scott at 2022-10-26T00:01:24-04:00 Broaden the in-scope sets for liftEnvSubst and composeTCvSubst This patch fixes two distinct (but closely related) buglets that were uncovered in #22235: * `liftEnvSubst` used an empty in-scope set, which was not wide enough to cover the variables in the range of the substitution. This patch fixes this by populating the in-scope set from the free variables in the range of the substitution. * `composeTCvSubst` applied the first substitution argument to the range of the second substitution argument, but the first substitution's in-scope set was not wide enough to cover the range of the second substutition. We similarly fix this issue in this patch by widening the first substitution's in-scope set before applying it. Fixes #22235. - - - - - 0270cc54 by Vladislav Zavialov at 2022-10-26T00:02:01-04:00 Introduce TcRnWithHsDocContext (#22346) Before this patch, GHC used withHsDocContext to attach an HsDocContext to an error message: addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg) The problem with this approach is that it only works with TcRnUnknownMessage. But could we attach an HsDocContext to a structured error message in a generic way? This patch solves the problem by introducing a new constructor to TcRnMessage: data TcRnMessage where ... TcRnWithHsDocContext :: !HsDocContext -> !TcRnMessage -> TcRnMessage ... - - - - - 9ab31f42 by Sylvain Henry at 2022-10-26T09:32:20+02:00 Testsuite: more precise test options Necessary for newer cross-compiling backends (JS, Wasm) that don't support TH yet. - - - - - f60a1a62 by Vladislav Zavialov at 2022-10-26T12:17:14-04:00 Use TcRnVDQInTermType in noNestedForallsContextsErr (#20115) When faced with VDQ in the type of a term, GHC generates the following error message: Illegal visible, dependent quantification in the type of a term (GHC does not yet support this) Prior to this patch, there were two ways this message could have been generated and represented: 1. with the dedicated constructor TcRnVDQInTermType (see check_type in GHC.Tc.Validity) 2. with the transitional constructor TcRnUnknownMessage (see noNestedForallsContextsErr in GHC.Rename.Utils) Not only this led to duplication of code generating the final SDoc, it also made it tricky to track the origin of the error message. This patch fixes the problem by using TcRnVDQInTermType exclusively. - - - - - 223e159d by Owen Shepherd at 2022-10-27T13:54:33-04:00 Remove source location information from interface files This change aims to minimize source location information leaking into interface files, which makes ABI hashes dependent on the build location. The `Binary (Located a)` instance has been removed completely. It seems that the HIE interface still needs the ability to serialize SrcSpans, but by wrapping the instances, it should be a lot more difficult to inadvertently add source location information. - - - - - 22e3deb9 by Simon Peyton Jones at 2022-10-27T13:55:37-04:00 Add missing dict binds to specialiser I had forgotten to add the auxiliary dict bindings to the /unfolding/ of a specialised function. This caused #22358, which reports failures when compiling Hackage packages fixed-vector indexed-traversable Regression test T22357 is snarfed from indexed-traversable - - - - - a8ed36f9 by Evan Relf at 2022-10-27T13:56:36-04:00 Fix broken link to `async` package - - - - - 750846cd by Zubin Duggal at 2022-10-28T00:49:22-04:00 Pass correct package db when testing stage1. It used to pick the db for stage-2 which obviously didn't work. - - - - - ad612f55 by Krzysztof Gogolewski at 2022-10-28T00:50:00-04:00 Minor SDoc-related cleanup * Rename pprCLabel to pprCLabelStyle, and use the name pprCLabel for a function using CStyle (analogous to pprAsmLabel) * Move LabelStyle to the CLabel module, it no longer needs to be in Outputable. * Move calls to 'text' right next to literals, to make sure the text/str rule is triggered. * Remove FastString/String roundtrip in Tc.Deriv.Generate * Introduce showSDocForUser', which abstracts over a pattern in GHCi.UI - - - - - c2872f3f by Bryan Richter at 2022-10-28T11:36:34+03:00 CI: Don't run lint-submods on nightly Fixes #22325 - - - - - 270037fa by Hécate Moonlight at 2022-10-28T19:46:12-04:00 Start the deprecation process for GHC.Pack - - - - - d45d8cb3 by M Farkas-Dyck at 2022-11-01T12:47:21-04:00 Drop a kludge for binutils<2.17, which is now over 10 years old. - - - - - 8ee8b418 by Nicolas Trangez at 2022-11-01T12:47:58-04:00 rts: `name` argument of `createOSThread` can be `const` Since we don't intend to ever change the incoming string, declare this to be true. Also, in the POSIX implementation, the argument is no longer `STG_UNUSED` (since ee0deb8054da2a597fc5624469b4c44fd769ada2) in any code path. See: https://gitlab.haskell.org/ghc/ghc/-/commit/ee0deb8054da2a597fc5624469b4c44fd769ada2#note_460080 - - - - - 13b5f102 by Nicolas Trangez at 2022-11-01T12:47:58-04:00 rts: fix lifetime of `start_thread`s `name` value Since, unlike the code in ee0deb8054da2^, usage of the `name` value passed to `createOSThread` now outlives said function's lifetime, and could hence be released by the caller by the time the new thread runs `start_thread`, it needs to be copied. See: https://gitlab.haskell.org/ghc/ghc/-/commit/ee0deb8054da2a597fc5624469b4c44fd769ada2#note_460080 See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9066 - - - - - edd175c9 by Nicolas Trangez at 2022-11-01T12:47:58-04:00 rts: fix OS thread naming in ticker Since ee0deb805, the use of `pthread_setname_np` on Darwin was fixed when invoking `createOSThread`. However, the 'ticker' has some thread-creation code which doesn't rely on `createOSThread`, yet also uses `pthread_setname_np`. This patch enforces all thread creation to go through a single function, which uses the (correct) thread-naming code introduced in ee0deb805. See: https://gitlab.haskell.org/ghc/ghc/-/commit/ee0deb8054da2a597fc5624469b4c44fd769ada2 See: https://gitlab.haskell.org/ghc/ghc/-/issues/22206 See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9066 - - - - - b7a00113 by Krzysztof Gogolewski at 2022-11-01T12:48:35-04:00 Typo: rename -fwrite-if-simplfied-core to -fwrite-if-simplified-core - - - - - 30e625e6 by Vladislav Zavialov at 2022-11-01T12:49:10-04:00 ThToHs: fix overzealous parenthesization Before this patch, when converting from TH.Exp to LHsExpr GhcPs, the compiler inserted more parentheses than required: ((f a) (b + c)) d This was happening because the LHS of the function application was parenthesized as if it was the RHS. Now we use funPrec and appPrec appropriately and produce sensibly parenthesized expressions: f a (b + c) d I also took the opportunity to remove the special case for LamE, which was not special at all and simply duplicated code. - - - - - 0560821f by Simon Peyton Jones at 2022-11-01T12:49:47-04:00 Add accurate skolem info when quantifying Ticket #22379 revealed that skolemiseQuantifiedTyVar was dropping the passed-in skol_info on the floor when it encountered a SkolemTv. Bad! Several TyCons thereby share a single SkolemInfo on their binders, which lead to bogus error reports. - - - - - 38d19668 by Fendor at 2022-11-01T12:50:25-04:00 Expose UnitEnvGraphKey for user-code - - - - - 77e24902 by Simon Peyton Jones at 2022-11-01T12:51:00-04:00 Shrink test case for #22357 Ryan Scott offered a cut-down repro case (60 lines instead of more than 700 lines) - - - - - 4521f649 by Simon Peyton Jones at 2022-11-01T12:51:00-04:00 Add two tests for #17366 - - - - - 6b400d26 by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: introduce (and use) `STG_NORETURN` Instead of sprinkling the codebase with `GNU(C3)_ATTRIBUTE(__noreturn__)`, add a `STG_NORETURN` macro (for, basically, the same thing) similar to `STG_UNUSED` and others, and update the code to use this macro where applicable. - - - - - f9638654 by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: consistently use `STG_UNUSED` - - - - - 81a58433 by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: introduce (and use) `STG_USED` Similar to `STG_UNUSED`, have a specific macro for `__attribute__(used)`. - - - - - 41e1f748 by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: introduce (and use) `STG_MALLOC` Instead of using `GNUC3_ATTRIBUTE(__malloc__)`, provide a `STG_MALLOC` macro definition and use it instead. - - - - - 3a9a8bde by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: use `STG_UNUSED` - - - - - 9ab999de by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: specify deallocator of allocating functions This patch adds a new `STG_MALLOC1` macro (and its counterpart `STG_MALLOC2` for completeness) which allows to specify the deallocation function to be used with allocations of allocating functions, and applies it to `stg*allocBytes`. It also fixes a case where `free` was used to free up an `stgMallocBytes` allocation, found by the above change. See: https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html#index-malloc-function-attribute See: https://gitlab.haskell.org/ghc/ghc/-/issues/22381 - - - - - 81c0c7c9 by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: use `alloc_size` attribute This patch adds the `STG_ALLOC_SIZE1` and `STG_ALLOC_SIZE2` macros which allow to set the `alloc_size` attribute on functions, when available. See: https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html#index-alloc_005fsize-function-attribute See: https://gitlab.haskell.org/ghc/ghc/-/issues/22381 - - - - - 99a1d896 by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: add and use `STG_RETURNS_NONNULL` See: https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html#index-returns_005fnonnull-function-attribute See: https://gitlab.haskell.org/ghc/ghc/-/issues/22381 - - - - - c235b399 by Nicolas Trangez at 2022-11-02T12:06:48-04:00 rts: tag `stgStrndup` as `STG_MALLOC` See: https://gitlab.haskell.org/ghc/ghc/-/issues/22381 - - - - - ed81b448 by Oleg Grenrus at 2022-11-02T12:07:27-04:00 Move Symbol implementation note out of public haddock - - - - - 284fd39c by Ben Gamari at 2022-11-03T01:58:54-04:00 gen-dll: Drop it Currently it is only used by the make build system, which is soon to be retired, and it has not built since 41cf758b. We may need to reintroduce it when dynamic-linking support is introduced on Windows, but we will cross that bridge once we get there. Fixes #21753. - - - - - 24f4f54f by Matthew Pickering at 2022-11-03T01:59:30-04:00 Port foundation numeric tests to GHC testsuite This commit ports the numeric tests which found a regression in GHC-9.4. https://github.com/haskell-foundation/foundation/issues/571 Included in the commit is a simple random number generator and simplified QuickCheck implementation. In future these could be factored out of this standalone file and reused as a general purpose library which could be used for other QuickCheck style tests in the testsuite. See #22282 - - - - - d51bf7bd by M Farkas-Dyck at 2022-11-03T02:00:13-04:00 git: ignore HIE files. Cleans up git status if one sets -fwrite-ide-info in hadrian/ghci. - - - - - a9fc15b1 by Matthew Pickering at 2022-11-03T02:00:49-04:00 Clarify status of bindings in WholeCoreBindings Gergo points out that these bindings are tidied, rather than prepd as the variable claims. Therefore we update the name of the variable to reflect reality and add a comment to the data type to try to erase any future confusion. Fixes #22307 - - - - - 634da448 by Bodigrim at 2022-11-03T21:25:02+00:00 Fix haddocks for GHC.IORef - - - - - 31125154 by Andreas Klebinger at 2022-11-03T23:08:09-04:00 Export pprTrace and friends from GHC.Prelude. Introduces GHC.Prelude.Basic which can be used in modules which are a dependency of the ppr code. - - - - - bdc8cbb3 by Bryan Richter at 2022-11-04T10:27:37+02:00 CI: Allow hadrian-ghc-in-ghci to run in nightlies Since lint-submods doesn't run in nightlies, hadrian-ghc-in-ghci needs to mark it as "optional" so it can run if the job doesn't exist. Fixes #22396. - - - - - 3c0e3793 by Krzysztof Gogolewski at 2022-11-05T00:29:57-04:00 Minor refactor around FastStrings Pass FastStrings to functions directly, to make sure the rule for fsLit "literal" fires. Remove SDoc indirection in GHCi.UI.Tags and GHC.Unit.Module.Graph. - - - - - e41b2f55 by Matthew Pickering at 2022-11-05T14:18:10+00:00 Bump unix submodule to 2.8.0.0 Also bumps process and ghc-boot bounds on unix. For hadrian, when cross-compiling, we add -Wwarn=unused-imports -Wwarn=unused-top-binds to validation flavour. Further fixes in unix and/or hsc2hs is needed to make it completely free of warnings; for the time being, this change is needed to unblock other cross-compilation related work. - - - - - 42938a58 by Matthew Pickering at 2022-11-05T14:18:10+00:00 Bump Win32 submodule to 2.13.4.0 Fixes #22098 - - - - - e7372bc5 by Cheng Shao at 2022-11-06T13:15:22+00:00 Bump ci-images revision ci-images has recently been updated, including changes needed for wasm32-wasi CI. - - - - - 88cb9492 by Cheng Shao at 2022-11-06T13:15:22+00:00 Bump gmp-tarballs submodule Includes a fix for wasm support, doesn't impact other targets. - - - - - 69427ce9 by Cheng Shao at 2022-11-06T13:15:22+00:00 Bump haskeline submodule Includes a fix for wasm support, doesn't impact other targets. - - - - - 5fe11fe6 by Carter Schonwald at 2022-11-07T13:22:14-05:00 bump llvm upper bound - - - - - 68f49874 by M Farkas-Dyck at 2022-11-08T12:53:55-05:00 Define `Infinite` list and use where appropriate. Also add perf test for infinite list fusion. In particular, in `GHC.Core`, often we deal with infinite lists of roles. Also in a few locations we deal with infinite lists of names. Thanks to simonpj for helping to write the Note [Fusion for `Infinite` lists]. - - - - - ce726cd2 by Ross Paterson at 2022-11-08T12:54:34-05:00 Fix TypeData issues (fixes #22315 and #22332) There were two bugs here: 1. Treating type-level constructors as PromotedDataCon doesn't always work, in particular because constructors promoted via DataKinds are called both T and 'T. (Tests T22332a, T22332b, T22315a, T22315b) Fix: guard these cases with isDataKindsPromotedDataCon. 2. Type-level constructors were sent to the code generator, producing things like constructor wrappers. (Tests T22332a, T22332b) Fix: test for them in isDataTyCon. Other changes: * changed the marking of "type data" DataCon's as suggested by SPJ. * added a test TDGADT for a type-level GADT. * comment tweaks * change tcIfaceTyCon to ignore IfaceTyConInfo, so that IfaceTyConInfo is used only for pretty printing, not for typechecking. (SPJ) - - - - - 132f8908 by Jade Lovelace at 2022-11-08T12:55:18-05:00 Clarify msum/asum documentation - - - - - bb5888c5 by Jade Lovelace at 2022-11-08T12:55:18-05:00 Add example for (<$) - - - - - 080fffa1 by Jade Lovelace at 2022-11-08T12:55:18-05:00 Document what Alternative/MonadPlus instances actually do - - - - - 92ccb8de by Giles Anderson at 2022-11-09T09:27:52-05:00 Use TcRnDiagnostic in GHC.Tc.TyCl.Instance (#20117) The following `TcRnDiagnostic` messages have been introduced: TcRnWarnUnsatisfiedMinimalDefinition TcRnMisplacedInstSig TcRnBadBootFamInstDeclErr TcRnIllegalFamilyInstance TcRnAssocInClassErr TcRnBadFamInstDecl TcRnNotOpenFamily - - - - - 90c5abd4 by Hécate Moonlight at 2022-11-09T09:28:30-05:00 GHCi tags generation phase 2 see #19884 - - - - - f9f17b68 by Simon Peyton Jones at 2022-11-10T12:20:03+00:00 Fire RULES in the Specialiser The Specialiser has, for some time, fires class-op RULES in the specialiser itself: see Note [Specialisation modulo dictionary selectors] This MR beefs it up a bit, so that it fires /all/ RULES in the specialiser, not just class-op rules. See Note [Fire rules in the specialiser] The result is a bit more specialisation; see test simplCore/should_compile/T21851_2 This pushed me into a bit of refactoring. I made a new data types GHC.Core.Rules.RuleEnv, which combines - the several source of rules (local, home-package, external) - the orphan-module dependencies in a single record for `getRules` to consult. That drove a bunch of follow-on refactoring, including allowing me to remove cr_visible_orphan_mods from the CoreReader data type. I moved some of the RuleBase/RuleEnv stuff into GHC.Core.Rule. The reorganisation in the Simplifier improve compile times a bit (geom mean -0.1%), but T9961 is an outlier Metric Decrease: T9961 - - - - - 2b3d0bee by Simon Peyton Jones at 2022-11-10T12:21:13+00:00 Make indexError work better The problem here is described at some length in Note [Boxity for bottoming functions] and Note [Reboxed crud for bottoming calls] in GHC.Core.Opt.DmdAnal. This patch adds a SPECIALISE pragma for indexError, which makes it much less vulnerable to the problem described in these Notes. (This came up in another line of work, where a small change made indexError do reboxing (in nofib/spectral/simple/table_sort) that didn't happen before my change. I've opened #22404 to document the fagility. - - - - - 399e921b by Simon Peyton Jones at 2022-11-10T12:21:14+00:00 Fix DsUselessSpecialiseForClassMethodSelector msg The error message for DsUselessSpecialiseForClassMethodSelector was just wrong (a typo in some earlier work); trivial fix - - - - - dac0682a by Sebastian Graf at 2022-11-10T21:16:01-05:00 WorkWrap: Unboxing unboxed tuples is not always useful (#22388) See Note [Unboxing through unboxed tuples]. Fixes #22388. - - - - - 1230c268 by Sebastian Graf at 2022-11-10T21:16:01-05:00 Boxity: Handle argument budget of unboxed tuples correctly (#21737) Now Budget roughly tracks the combined width of all arguments after unarisation. See the changes to `Note [Worker argument budgets]`. Fixes #21737. - - - - - 2829fd92 by Cheng Shao at 2022-11-11T00:26:54-05:00 autoconf: check getpid getuid raise This patch adds checks for getpid, getuid and raise in autoconf. These functions are absent in wasm32-wasi and thus needs to be checked. - - - - - f5dfd1b4 by Cheng Shao at 2022-11-11T00:26:55-05:00 hadrian: add -Wwarn only for cross-compiling unix - - - - - 2e6ab453 by Cheng Shao at 2022-11-11T00:26:55-05:00 hadrian: add targetSupportsThreadedRts flag This patch adds a targetSupportsThreadedRts flag to indicate whether the target supports the threaded rts at all, different from existing targetSupportsSMP that checks whether -N is supported by the RTS. All existing flavours have also been updated accordingly to respect this flags. Some targets (e.g. wasm32-wasi) does not support the threaded rts, therefore this flag is needed for the default flavours to work. It makes more sense to have proper autoconf logic to check for threading support, but for the time being, we just set the flag to False iff the target is wasm32. - - - - - 8104f6f5 by Cheng Shao at 2022-11-11T00:26:55-05:00 Fix Cmm symbol kind - - - - - b2035823 by Norman Ramsey at 2022-11-11T00:26:55-05:00 add the two key graph modules from Martin Erwig's FGL Martin Erwig's FGL (Functional Graph Library) provides an "inductive" representation of graphs. A general graph has labeled nodes and labeled edges. The key operation on a graph is to decompose it by removing one node, together with the edges that connect the node to the rest of the graph. There is also an inverse composition operation. The decomposition and composition operations make this representation of graphs exceptionally well suited to implement graph algorithms in which the graph is continually changing, as alluded to in #21259. This commit adds `GHC.Data.Graph.Inductive.Graph`, which defines the interface, and `GHC.Data.Graph.Inductive.PatriciaTree`, which provides an implementation. Both modules are taken from `fgl-5.7.0.3` on Hackage, with these changes: - Copyright and license text have been copied into the files themselves, not stored separately. - Some calls to `error` have been replaced with calls to `panic`. - Conditional-compilation support for older versions of GHC, `containers`, and `base` has been removed. - - - - - 3633a5f5 by Norman Ramsey at 2022-11-11T00:26:55-05:00 add new modules for reducibility and WebAssembly translation - - - - - df7bfef8 by Cheng Shao at 2022-11-11T00:26:55-05:00 Add support for the wasm32-wasi target tuple This patch adds the wasm32-wasi tuple support to various places in the tree: autoconf, hadrian, ghc-boot and also the compiler. The codegen logic will come in subsequent commits. - - - - - 32ae62e6 by Cheng Shao at 2022-11-11T00:26:55-05:00 deriveConstants: parse .ll output for wasm32 due to broken nm This patch makes deriveConstants emit and parse an .ll file when targeting wasm. It's a necessary workaround for broken llvm-nm on wasm, which isn't capable of reporting correct constant values when parsing an object. - - - - - 07e92c92 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: workaround cmm's improper variadic ccall breaking wasm32 typechecking Unlike other targets, wasm requires the function signature of the call site and callee to strictly match. So in Cmm, when we call a C function that actually returns a value, we need to add an _unused local variable to receive it, otherwise type error awaits. An even bigger problem is calling variadic functions like barf() and such. Cmm doesn't support CAPI calling convention yet, so calls to variadic functions just happen to work in some cases with some target's ABI. But again, it doesn't work with wasm. Fortunately, the wasm C ABI lowers varargs to a stack pointer argument, and it can be passed NULL when no other arguments are expected to be passed. So we also add the additional unused NULL arguments to those functions, so to fix wasm, while not affecting behavior on other targets. - - - - - 00124d12 by Cheng Shao at 2022-11-11T00:26:55-05:00 testsuite: correct sleep() signature in T5611 In libc, sleep() returns an integer. The ccall type signature should match the libc definition, otherwise it causes linker error on wasm. - - - - - d72466a9 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: prefer ffi_type_void over FFI_TYPE_VOID This patch uses ffi_type_void instead of FFI_TYPE_VOID in the interpreter code, since the FFI_TYPE_* macros are not available in libffi-wasm32 yet. The libffi public documentation also only mentions the lower-case ffi_type_* symbols, so we should prefer the lower-case API here. - - - - - 4d36a1d3 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: don't define RTS_USER_SIGNALS when signal.h is not present In the rts, we have a RTS_USER_SIGNALS macro, and most signal-related logic is guarded with RTS_USER_SIGNALS. This patch extends the range of code guarded with RTS_USER_SIGNALS, and define RTS_USER_SIGNALS iff signal.h is actually detected by autoconf. This is required for wasm32-wasi to work, which lacks signals. - - - - - 3f1e164f by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: use HAVE_GETPID to guard subprocess related logic We've previously added detection of getpid() in autoconf. This patch uses HAVE_GETPID to guard some subprocess related logic in the RTS. This is required for certain targets like wasm32-wasi, where there isn't a process model at all. - - - - - 50bf5e77 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: IPE.c: don't do mutex stuff when THREADED_RTS is not defined This patch adds the missing THREADED_RTS CPP guard to mutex logic in IPE.c. - - - - - ed3b3da0 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: genericRaise: use exit() instead when not HAVE_RAISE We check existence of raise() in autoconf, and here, if not HAVE_RAISE, we should use exit() instead in genericRaise. - - - - - c0ba1547 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: checkSuid: don't do it when not HAVE_GETUID When getuid() is not present, don't do checkSuid since it doesn't make sense anyway on that target. - - - - - d2d6dfd2 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: wasm32 placeholder linker This patch adds minimal placeholder linker logic for wasm32, just enough to unblock compiling rts on wasm32. RTS linker functionality is not properly implemented yet for wasm32. - - - - - 65ba3285 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: RtsStartup: chdir to PWD on wasm32 This patch adds a wasm32-specific behavior to RtsStartup logic. When the PWD environment variable is present, we chdir() to it first. The point is to workaround an issue in wasi-libc: it's currently not possible to specify the initial working directory, it always defaults to / (in the virtual filesystem mapped from some host directory). For some use cases this is sufficient, but there are some other cases (e.g. in the testsuite) where the program needs to access files outside. - - - - - 65b82542 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: no timer for wasm32 Due to the lack of threads, on wasm32 there can't be a background timer that periodically resets the context switch flag. This patch disables timer for wasm32, and also makes the scheduler default to -C0 on wasm32 to avoid starving threads. - - - - - e007586f by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: RtsSymbols: empty RTS_POSIX_ONLY_SYMBOLS for wasm32 The default RTS_POSIX_ONLY_SYMBOLS doesn't make sense on wasm32. - - - - - 0e33f667 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: Schedule: no FORKPROCESS_PRIMOP_SUPPORTED on wasm32 On wasm32 there isn't a process model at all, so no FORKPROCESS_PRIMOP_SUPPORTED. - - - - - 88bbdb31 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: LibffiAdjustor: adapt to ffi_alloc_prep_closure interface for wasm32 libffi-wasm32 only supports non-standard libffi closure api via ffi_alloc_prep_closure(). This patch implements ffi_alloc_prep_closure() via standard libffi closure api on other targets, and uses it to implement adjustor functionality. - - - - - 15138746 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: don't return memory to OS on wasm32 This patch makes the storage manager not return any memory on wasm32. The detailed reason is described in Note [Megablock allocator on wasm]. - - - - - 631af3cc by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: make flushExec a no-op on wasm32 This patch makes flushExec a no-op on wasm32, since there's no such thing as executable memory on wasm32 in the first place. - - - - - 654a3d46 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: RtsStartup: don't call resetTerminalSettings, freeThreadingResources on wasm32 This patch prevents resetTerminalSettings and freeThreadingResources to be called on wasm32, since there is no TTY or threading on wasm32 at all. - - - - - f271e7ca by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: OSThreads.h: stub types for wasm32 This patch defines stub Condition/Mutex/OSThreadId/ThreadLocalKey types for wasm32, just enough to unblock compiling RTS. Any threading-related functionality has been patched to be disabled on wasm32. - - - - - a6ac67b0 by Cheng Shao at 2022-11-11T00:26:55-05:00 Add register mapping for wasm32 This patch adds register mapping logic for wasm32. See Note [Register mapping on WebAssembly] in wasm32 NCG for more description. - - - - - d7b33982 by Cheng Shao at 2022-11-11T00:26:55-05:00 rts: wasm32 specific logic This patch adds the rest of wasm32 specific logic in rts. - - - - - 7f59b0f3 by Cheng Shao at 2022-11-11T00:26:55-05:00 base: fall back to using monotonic clock to emulate cputime on wasm32 On wasm32, we have to fall back to using monotonic clock to emulate cputime, since there's no native support for cputime as a clock id. - - - - - 5fcbae0b by Cheng Shao at 2022-11-11T00:26:55-05:00 base: more autoconf checks for wasm32 This patch adds more autoconf checks to base, since those functions and headers may exist on other POSIX systems but don't exist on wasm32. - - - - - 00a9359f by Cheng Shao at 2022-11-11T00:26:55-05:00 base: avoid using unsupported posix functionality on wasm32 This base patch avoids using unsupported posix functionality on wasm32. - - - - - 34b8f611 by Cheng Shao at 2022-11-11T00:26:55-05:00 autoconf: set CrossCompiling=YES in cross bindist configure This patch fixes the bindist autoconf logic to properly set CrossCompiling=YES when it's a cross GHC bindist. - - - - - 5ebeaa45 by Cheng Shao at 2022-11-11T00:26:55-05:00 compiler: add util functions for UniqFM and UniqMap This patch adds addToUFM_L (backed by insertLookupWithKey), addToUniqMap_L and intersectUniqMap_C. These UniqFM/UniqMap util functions are used by the wasm32 NCG. - - - - - 177c56c1 by Cheng Shao at 2022-11-11T00:26:55-05:00 driver: avoid -Wl,--no-as-needed for wasm32 The driver used to pass -Wl,--no-as-needed for LLD linking. This is actually only supported for ELF targets, and must be avoided when linking for wasm32. - - - - - 06f01c74 by Cheng Shao at 2022-11-11T00:26:55-05:00 compiler: allow big arith for wasm32 This patch enables Cmm big arithmetic on wasm32, since 64-bit arithmetic can be efficiently lowered to wasm32 opcodes. - - - - - df6bb112 by Cheng Shao at 2022-11-11T00:26:55-05:00 driver: pass -Wa,--no-type-check for wasm32 when runAsPhase This patch passes -Wa,--no-type-check for wasm32 when compiling assembly. See the added note for more detailed explanation. - - - - - c1fe4ab6 by Cheng Shao at 2022-11-11T00:26:55-05:00 compiler: enforce cmm switch planning for wasm32 This patch forcibly enable Cmm switch planning for wasm32, since otherwise the switch tables we generate may exceed the br_table maximum allowed size. - - - - - a8adc71e by Cheng Shao at 2022-11-11T00:26:55-05:00 compiler: annotate CmmFileEmbed with blob length This patch adds the blob length field to CmmFileEmbed. The wasm32 NCG needs to know the precise size of each data segment. - - - - - 36340328 by Cheng Shao at 2022-11-11T00:26:55-05:00 compiler: wasm32 NCG This patch adds the wasm32 NCG. - - - - - 435f42ea by Cheng Shao at 2022-11-11T00:26:55-05:00 ci: add wasm32-wasi release bindist job - - - - - d8262fdc by Cheng Shao at 2022-11-11T00:26:55-05:00 ci: add a stronger test for cross bindists This commit adds a simple GHC API program that parses and reprints the original hello world program used for basic testing of cross bindists. Before there's full cross-compilation support in the test suite driver, this provides better coverage than the original test. - - - - - 8e6ae882 by Cheng Shao at 2022-11-11T00:26:55-05:00 CODEOWNERS: add wasm-specific maintainers - - - - - 707d5651 by Zubin Duggal at 2022-11-11T00:27:31-05:00 Clarify that LLVM upper bound is non-inclusive during configure (#22411) - - - - - 430eccef by Ben Gamari at 2022-11-11T13:16:45-05:00 rts: Check for program_invocation_short_name via autoconf Instead of assuming support on all Linuxes. - - - - - 6dab0046 by Matthew Pickering at 2022-11-11T13:17:22-05:00 driver: Fix -fdefer-diagnostics flag The `withDeferredDiagnostics` wrapper wasn't doing anything because the session it was modifying wasn't used in hsc_env. Therefore the fix is simple, just push the `getSession` call into the scope of `withDeferredDiagnostics`. Fixes #22391 - - - - - d0c691b6 by Simon Peyton Jones at 2022-11-11T13:18:07-05:00 Add a fast path for data constructor workers See Note [Fast path for data constructors] in GHC.Core.Opt.Simplify.Iteration This bypasses lots of expensive logic, in the special case of applications of data constructors. It is a surprisingly worthwhile improvement, as you can see in the figures below. Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Read(normal) -2.0% CoOpt_Singletons(normal) -2.0% ManyConstructors(normal) -1.3% T10421(normal) -1.9% GOOD T10421a(normal) -1.5% T10858(normal) -1.6% T11545(normal) -1.7% T12234(optasm) -1.3% T12425(optasm) -1.9% GOOD T13035(normal) -1.0% GOOD T13056(optasm) -1.8% T13253(normal) -3.3% GOOD T15164(normal) -1.7% T15304(normal) -3.4% T15630(normal) -2.8% T16577(normal) -4.3% GOOD T17096(normal) -1.1% T17516(normal) -3.1% T18282(normal) -1.9% T18304(normal) -1.2% T18698a(normal) -1.2% GOOD T18698b(normal) -1.5% GOOD T18923(normal) -1.3% T1969(normal) -1.3% GOOD T19695(normal) -4.4% GOOD T21839c(normal) -2.7% GOOD T21839r(normal) -2.7% GOOD T4801(normal) -3.8% GOOD T5642(normal) -3.1% GOOD T6048(optasm) -2.5% GOOD T9020(optasm) -2.7% GOOD T9630(normal) -2.1% GOOD T9961(normal) -11.7% GOOD WWRec(normal) -1.0% geo. mean -1.1% minimum -11.7% maximum +0.1% Metric Decrease: T10421 T12425 T13035 T13253 T16577 T18698a T18698b T1969 T19695 T21839c T21839r T4801 T5642 T6048 T9020 T9630 T9961 - - - - - 3c37d30b by Krzysztof Gogolewski at 2022-11-11T19:18:39+01:00 Use a more efficient printer for code generation (#21853) The changes in `GHC.Utils.Outputable` are the bulk of the patch and drive the rest. The types `HLine` and `HDoc` in Outputable can be used instead of `SDoc` and support printing directly to a handle with `bPutHDoc`. See Note [SDoc versus HDoc] and Note [HLine versus HDoc]. The classes `IsLine` and `IsDoc` are used to make the existing code polymorphic over `HLine`/`HDoc` and `SDoc`. This is done for X86, PPC, AArch64, DWARF and dependencies (printing module names, labels etc.). Co-authored-by: Alexis King <lexi.lambda at gmail.com> Metric Decrease: CoOpt_Read ManyAlternatives ManyConstructors T10421 T12425 T12707 T13035 T13056 T13253 T13379 T18140 T18282 T18698a T18698b T1969 T20049 T21839c T21839r T3064 T3294 T4801 T5321FD T5321Fun T5631 T6048 T783 T9198 T9233 - - - - - 6b92b47f by Matthew Craven at 2022-11-11T18:32:14-05:00 Weaken wrinkle 1 of Note [Scrutinee Constant Folding] Fixes #22375. Co-authored-by: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - 154c70f6 by Simon Peyton Jones at 2022-11-11T23:40:10+00:00 Fix fragile RULE setup in GHC.Float In testing my type-vs-constraint patch I found that the handling of Natural literals was very fragile -- and I somehow tripped that fragility in my work. So this patch fixes the fragility. See Note [realToFrac natural-to-float] This made a big (9%) difference in one existing test in perf/should_run/T1-359 Metric Decrease: T10359 - - - - - 778c6adc by Simon Peyton Jones at 2022-11-11T23:40:10+00:00 Type vs Constraint: finally nailed This big patch addresses the rats-nest of issues that have plagued us for years, about the relationship between Type and Constraint. See #11715/#21623. The main payload of the patch is: * To introduce CONSTRAINT :: RuntimeRep -> Type * To make TYPE and CONSTRAINT distinct throughout the compiler Two overview Notes in GHC.Builtin.Types.Prim * Note [TYPE and CONSTRAINT] * Note [Type and Constraint are not apart] This is the main complication. The specifics * New primitive types (GHC.Builtin.Types.Prim) - CONSTRAINT - ctArrowTyCon (=>) - tcArrowTyCon (-=>) - ccArrowTyCon (==>) - funTyCon FUN -- Not new See Note [Function type constructors and FunTy] and Note [TYPE and CONSTRAINT] * GHC.Builtin.Types: - New type Constraint = CONSTRAINT LiftedRep - I also stopped nonEmptyTyCon being built-in; it only needs to be wired-in * Exploit the fact that Type and Constraint are distinct throughout GHC - Get rid of tcView in favour of coreView. - Many tcXX functions become XX functions. e.g. tcGetCastedTyVar --> getCastedTyVar * Kill off Note [ForAllTy and typechecker equality], in (old) GHC.Tc.Solver.Canonical. It said that typechecker-equality should ignore the specified/inferred distinction when comparein two ForAllTys. But that wsa only weakly supported and (worse) implies that we need a separate typechecker equality, different from core equality. No no no. * GHC.Core.TyCon: kill off FunTyCon in data TyCon. There was no need for it, and anyway now we have four of them! * GHC.Core.TyCo.Rep: add two FunTyFlags to FunCo See Note [FunCo] in that module. * GHC.Core.Type. Lots and lots of changes driven by adding CONSTRAINT. The key new function is sORTKind_maybe; most other changes are built on top of that. See also `funTyConAppTy_maybe` and `tyConAppFun_maybe`. * Fix a longstanding bug in GHC.Core.Type.typeKind, and Core Lint, in kinding ForAllTys. See new tules (FORALL1) and (FORALL2) in GHC.Core.Type. (The bug was that before (forall (cv::t1 ~# t2). blah), where blah::TYPE IntRep, would get kind (TYPE IntRep), but it should be (TYPE LiftedRep). See Note [Kinding rules for types] in GHC.Core.Type. * GHC.Core.TyCo.Compare is a new module in which we do eqType and cmpType. Of course, no tcEqType any more. * GHC.Core.TyCo.FVs. I moved some free-var-like function into this module: tyConsOfType, visVarsOfType, and occCheckExpand. Refactoring only. * GHC.Builtin.Types. Compiletely re-engineer boxingDataCon_maybe to have one for each /RuntimeRep/, rather than one for each /Type/. This dramatically widens the range of types we can auto-box. See Note [Boxing constructors] in GHC.Builtin.Types The boxing types themselves are declared in library ghc-prim:GHC.Types. GHC.Core.Make. Re-engineer the treatment of "big" tuples (mkBigCoreVarTup etc) GHC.Core.Make, so that it auto-boxes unboxed values and (crucially) types of kind Constraint. That allows the desugaring for arrows to work; it gathers up free variables (including dictionaries) into tuples. See Note [Big tuples] in GHC.Core.Make. There is still work to do here: #22336. But things are better than before. * GHC.Core.Make. We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and aBSENT_CONSTRAINT_ERROR_ID for vaues of kind Constraint. Ditto noInlineId vs noInlieConstraintId in GHC.Types.Id.Make; see Note [inlineId magic]. * GHC.Core.TyCo.Rep. Completely refactor the NthCo coercion. It is now called SelCo, and its fields are much more descriptive than the single Int we used to have. A great improvement. See Note [SelCo] in GHC.Core.TyCo.Rep. * GHC.Core.RoughMap.roughMatchTyConName. Collapse TYPE and CONSTRAINT to a single TyCon, so that the rough-map does not distinguish them. * GHC.Core.DataCon - Mainly just improve documentation * Some significant renamings: GHC.Core.Multiplicity: Many --> ManyTy (easier to grep for) One --> OneTy GHC.Core.TyCo.Rep TyCoBinder --> GHC.Core.Var.PiTyBinder GHC.Core.Var TyCoVarBinder --> ForAllTyBinder AnonArgFlag --> FunTyFlag ArgFlag --> ForAllTyFlag GHC.Core.TyCon TyConTyCoBinder --> TyConPiTyBinder Many functions are renamed in consequence e.g. isinvisibleArgFlag becomes isInvisibleForAllTyFlag, etc * I refactored FunTyFlag (was AnonArgFlag) into a simple, flat data type data FunTyFlag = FTF_T_T -- (->) Type -> Type | FTF_T_C -- (-=>) Type -> Constraint | FTF_C_T -- (=>) Constraint -> Type | FTF_C_C -- (==>) Constraint -> Constraint * GHC.Tc.Errors.Ppr. Some significant refactoring in the TypeEqMisMatch case of pprMismatchMsg. * I made the tyConUnique field of TyCon strict, because I saw code with lots of silly eval's. That revealed that GHC.Settings.Constants.mAX_SUM_SIZE can only be 63, because we pack the sum tag into a 6-bit field. (Lurking bug squashed.) Fixes * #21530 Updates haddock submodule slightly. Performance changes ~~~~~~~~~~~~~~~~~~~ I was worried that compile times would get worse, but after some careful profiling we are down to a geometric mean 0.1% increase in allocation (in perf/compiler). That seems fine. There is a big runtime improvement in T10359 Metric Decrease: LargeRecord MultiLayerModulesTH_OneShot T13386 T13719 Metric Increase: T8095 - - - - - 360f5fec by Simon Peyton Jones at 2022-11-11T23:40:11+00:00 Indent closing "#-}" to silence HLint - - - - - e160cf47 by Krzysztof Gogolewski at 2022-11-12T08:05:28-05:00 Fix merge conflict in T18355.stderr Fixes #22446 - - - - - 294f9073 by Simon Peyton Jones at 2022-11-12T23:14:13+00:00 Fix a trivial typo in dataConNonlinearType Fixes #22416 - - - - - 268a3ce9 by Ben Gamari at 2022-11-14T09:36:57-05:00 eventlog: Ensure that IPE output contains actual info table pointers The refactoring in 866c736e introduced a rather subtle change in the semantics of the IPE eventlog output, changing the eventlog field from encoding info table pointers to "TNTC pointers" (which point to entry code when tables-next-to-code is enabled). Fix this. Fixes #22452. - - - - - d91db679 by Matthew Pickering at 2022-11-14T16:48:10-05:00 testsuite: Add tests for T22347 These are fixed in recent versions but might as well add regression tests. See #22347 - - - - - 8f6c576b by Matthew Pickering at 2022-11-14T16:48:45-05:00 testsuite: Improve output from tests which have failing pre_cmd There are two changes: * If a pre_cmd fails, then don't attempt to run the test. * If a pre_cmd fails, then print the stdout and stderr from running that command (which hopefully has a nice error message). For example: ``` =====> 1 of 1 [0, 0, 0] *** framework failure for test-defaulting-plugin(normal) pre_cmd failed: 2 ** pre_cmd was "$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin TOP={top}". stdout: stderr: DefaultLifted.hs:19:13: error: [GHC-76037] Not in scope: type constructor or class ‘Typ’ Suggested fix: Perhaps use one of these: ‘Type’ (imported from GHC.Tc.Utils.TcType), data constructor ‘Type’ (imported from GHC.Plugins) | 19 | instance Eq Typ where | ^^^ make: *** [Makefile:17: package.test-defaulting-plugin] Error 1 Performance Metrics (test environment: local): ``` Fixes #22329 - - - - - 2b7d5ccc by Madeline Haraj at 2022-11-14T22:44:17+00:00 Implement UNPACK support for sum types. This is based on osa's unpack_sums PR from ages past. The meat of the patch is implemented in dataConArgUnpackSum and described in Note [UNPACK for sum types]. - - - - - 78f7ecb0 by Andreas Klebinger at 2022-11-14T22:20:29-05:00 Expand on the need to clone local binders. Fixes #22402. - - - - - 65ce43cc by Krzysztof Gogolewski at 2022-11-14T22:21:05-05:00 Fix :i Constraint printing "type Constraint = Constraint" Since Constraint became a synonym for CONSTRAINT 'LiftedRep, we need the same code for handling printing as for the synonym Type = TYPE 'LiftedRep. This addresses the same bug as #18594, so I'm reusing the test. - - - - - 94549f8f by ARATA Mizuki at 2022-11-15T21:36:03-05:00 configure: Don't check for an unsupported version of LLVM The upper bound is not inclusive. Fixes #22449 - - - - - 02d3511b by Bodigrim at 2022-11-15T21:36:41-05:00 Fix capitalization in haddock for TestEquality - - - - - 08bf2881 by Cheng Shao at 2022-11-16T09:16:29+00:00 base: make Foreign.Marshal.Pool use RTS internal arena for allocation `Foreign.Marshal.Pool` used to call `malloc` once for each allocation request. Each `Pool` maintained a list of allocated pointers, and traverses the list to `free` each one of those pointers. The extra O(n) overhead is apparently bad for a `Pool` that serves a lot of small allocation requests. This patch uses the RTS internal arena to implement `Pool`, with these benefits: - Gets rid of the extra O(n) overhead. - The RTS arena is simply a bump allocator backed by the block allocator, each allocation request is likely faster than a libc `malloc` call. Closes #14762 #18338. - - - - - 37cfe3c0 by Krzysztof Gogolewski at 2022-11-16T14:50:06-05:00 Misc cleanup * Replace catMaybes . map f with mapMaybe f * Use concatFS to concatenate multiple FastStrings * Fix documentation of -exclude-module * Cleanup getIgnoreCount in GHCi.UI - - - - - b0ac3813 by Lawton Nichols at 2022-11-19T03:22:14-05:00 Give better errors for code corrupted by Unicode smart quotes (#21843) Previously, we emitted a generic and potentially confusing error during lexical analysis on programs containing smart quotes (“/”/‘/’). This commit adds smart quote-aware lexer errors. - - - - - cb8430f8 by Sebastian Graf at 2022-11-19T03:22:49-05:00 Make OpaqueNo* tests less noisy to unrelated changes - - - - - b1a8af69 by Sebastian Graf at 2022-11-19T03:22:49-05:00 Simplifier: Consider `seq` as a `BoringCtxt` (#22317) See `Note [Seq is boring]` for the rationale. Fixes #22317. - - - - - 9fd11585 by Sebastian Graf at 2022-11-19T03:22:49-05:00 Make T21839c's ghc/max threshold more forgiving - - - - - 4b6251ab by Simon Peyton Jones at 2022-11-19T03:23:24-05:00 Be more careful when reporting unbound RULE binders See Note [Variables unbound on the LHS] in GHC.HsToCore.Binds. Fixes #22471. - - - - - e8f2b80d by Peter Trommler at 2022-11-19T03:23:59-05:00 PPC NCG: Fix generating assembler code Fixes #22479 - - - - - f2f9ef07 by Bodigrim at 2022-11-20T18:39:30-05:00 Extend documentation for Data.IORef - - - - - ef511b23 by Simon Peyton Jones at 2022-11-20T18:40:05-05:00 Buglet in GHC.Tc.Module.checkBootTyCon This lurking bug used the wrong function to compare two types in GHC.Tc.Module.checkBootTyCon It's hard to trigger the bug, which only came up during !9343, so there's no regression test in this MR. - - - - - 451aeac3 by Bodigrim at 2022-11-20T18:40:44-05:00 Add since pragmas for c_interruptible_open and hostIsThreaded - - - - - 8d6aaa49 by Duncan Coutts at 2022-11-22T02:06:16-05:00 Introduce CapIOManager as the per-cap I/O mangager state Rather than each I/O manager adding things into the Capability structure ad-hoc, we should have a common CapIOManager iomgr member of the Capability structure, with a common interface to initialise etc. The content of the CapIOManager struct will be defined differently for each I/O manager implementation. Eventually we should be able to have the CapIOManager be opaque to the rest of the RTS, and known just to the I/O manager implementation. We plan for that by making the Capability contain a pointer to the CapIOManager rather than containing the structure directly. Initially just move the Unix threaded I/O manager's control FD. - - - - - 8901285e by Duncan Coutts at 2022-11-22T02:06:17-05:00 Add hook markCapabilityIOManager To allow I/O managers to have GC roots in the Capability, within the CapIOManager structure. Not yet used in this patch. - - - - - 5cf709c5 by Duncan Coutts at 2022-11-22T02:06:17-05:00 Move APPEND_TO_BLOCKED_QUEUE from cmm to C The I/O and delay blocking primitives for the non-threaded way currently access the blocked_queue and sleeping_queue directly. We want to move where those queues are to make their ownership clearer: to have them clearly belong to the I/O manager impls rather than to the scheduler. Ultimately we will want to change their representation too. It's inconvenient to do that if these queues are accessed directly from cmm code. So as a first step, replace the APPEND_TO_BLOCKED_QUEUE with a C version appendToIOBlockedQueue(), and replace the open-coded sleeping_queue insertion with insertIntoSleepingQueue(). - - - - - ced9acdb by Duncan Coutts at 2022-11-22T02:06:17-05:00 Move {blocked,sleeping}_queue from scheduler global vars to CapIOManager The blocked_queue_{hd,tl} and the sleeping_queue are currently cooperatively managed between the scheduler and (some but not all of) the non-threaded I/O manager implementations. They lived as global vars with the scheduler, but are poked by I/O primops and the I/O manager backends. This patch is a step on the path towards making the management of I/O or timer blocking belong to the I/O managers and not the scheduler. Specifically, this patch moves the {blocked,sleeping}_queue from being global vars in the scheduler to being members of the CapIOManager struct within each Capability. They are not yet exclusively used by the I/O managers: they are still poked from a couple other places, notably in the scheduler before calling awaitEvent. - - - - - 0f68919e by Duncan Coutts at 2022-11-22T02:06:17-05:00 Remove the now-unused markScheduler The global vars {blocked,sleeping}_queue are now in the Capability and so get marked there via markCapabilityIOManager. - - - - - 39a91f60 by Duncan Coutts at 2022-11-22T02:06:17-05:00 Move macros for checking for pending IO or timers from Schedule.h to Schedule.c and IOManager.h This is just moving, the next step will be to rejig them slightly. For the non-threaded RTS the scheduler needs to be able to test for there being pending I/O operation or pending timers. The implementation of these tests should really be considered to be part of the I/O managers and not part of the scheduler. - - - - - 664b034b by Duncan Coutts at 2022-11-22T02:06:17-05:00 Replace EMPTY_{BLOCKED,SLEEPING}_QUEUE macros by function These are the macros originaly from Scheduler.h, previously moved to IOManager.h, and now replaced with a single inline function anyPendingTimeoutsOrIO(). We can use a single function since the two macros were always checked together. Note that since anyPendingTimeoutsOrIO is defined for all IO manager cases, including threaded, we do not need to guard its use by cpp #if !defined(THREADED_RTS) - - - - - 32946220 by Duncan Coutts at 2022-11-22T02:06:17-05:00 Expand emptyThreadQueues inline for clarity It was not really adding anything. The name no longer meant anything since those I/O and timeout queues do not belong to the scheuler. In one of the two places it was used, the comments already had to explain what it did, whereas now the code matches the comment nicely. - - - - - 9943baf9 by Duncan Coutts at 2022-11-22T02:06:17-05:00 Move the awaitEvent declaration into IOManager.h And add or adjust comments at the use sites of awaitEvent. - - - - - 054dcc9d by Duncan Coutts at 2022-11-22T02:06:17-05:00 Pass the Capability *cap explicitly to awaitEvent It is currently only used in the non-threaded RTS so it works to use MainCapability, but it's a bit nicer to pass the cap anyway. It's certainly shorter. - - - - - 667fe5a4 by Duncan Coutts at 2022-11-22T02:06:17-05:00 Pass the Capability *cap explicitly to appendToIOBlockedQueue And to insertIntoSleepingQueue. Again, it's a bit cleaner and simpler though not strictly necessary given that these primops are currently only used in the non-threaded RTS. - - - - - 7181b074 by Duncan Coutts at 2022-11-22T02:06:17-05:00 Reveiew feedback: improve one of the TODO comments The one about the nonsense (const False) test on WinIO for there being any IO or timers pending, leading to unnecessary complication later in the scheduler. - - - - - e5b68183 by Andreas Klebinger at 2022-11-22T02:06:52-05:00 Optimize getLevity. Avoid the intermediate data structures allocated by splitTyConApp. This avoids ~0.5% of allocations for a build using -O2. Fixes #22254 - - - - - de5fb348 by Andreas Klebinger at 2022-11-22T02:07:28-05:00 hadrian:Set TNTC when running testsuite. - - - - - 9d61c182 by Oleg Grenrus at 2022-11-22T15:59:34-05:00 Add unsafePtrEquality# restricted to UnliftedTypes - - - - - e817c871 by Jonathan Dowland at 2022-11-22T16:00:14-05:00 utils/unlit: adjust parser to match Report spec The Haskell 2010 Report says that, for Latex-style Literate format, "Program code begins on the first line following a line that begins \begin{code}". (This is unchanged from the 98 Report) However the unlit.c implementation only matches a line that contains "\begin{code}" and nothing else. One consequence of this is that one cannot suffix Latex options to the code environment. I.e., this does not work: \begin{code}[label=foo,caption=Foo Code] Adjust the matcher to conform to the specification from the Report. The Haskell Wiki currently recommends suffixing a '%' to \begin{code} in order to deliberately hide a code block from Haskell. This is bad advice, as it's relying on an implementation quirk rather than specified behaviour. None-the-less, some people have tried to use it, c.f. <https://mail.haskell.org/pipermail/haskell-cafe/2009-September/066780.html> An alternative solution is to define a separate, equivalent Latex environment to "code", that is functionally identical in Latex but ignored by unlit. This should not be a burden: users are required to manually define the code environment anyway, as it is not provided by the Latex verbatim or lstlistings packages usually used for presenting code in documents. Fixes #3549. - - - - - 0b7fef11 by Teo Camarasu at 2022-11-23T12:44:33-05:00 Fix eventlog all option Previously it didn't enable/disable nonmoving_gc and ticky event types Fixes #21813 - - - - - 04d0618c by Arnaud Spiwack at 2022-11-23T12:45:14-05:00 Expand Note [Linear types] with the stance on linting linearity Per the discussion on #22123 - - - - - e1538516 by Lawton Nichols at 2022-11-23T12:45:55-05:00 Add documentation on custom Prelude modules (#22228) Specifically, custom Prelude modules that are named `Prelude`. - - - - - b5c71454 by Sylvain Henry at 2022-11-23T12:46:35-05:00 Don't let configure perform trivial substitutions (#21846) Hadrian now performs substitutions, especially to generate .cabal files from .cabal.in files. Two benefits: 1. We won't have to re-configure when we modify thing.cabal.in. Hadrian will take care of this for us. 2. It paves the way to allow the same package to be configured differently by Hadrian in the same session. This will be useful to fix #19174: we want to build a stage2 cross-compiler for the host platform and a stage1 compiler for the cross target platform in the same Hadrian session. - - - - - 99aca26b by nineonine at 2022-11-23T12:47:11-05:00 CApiFFI: add ConstPtr for encoding const-qualified pointer return types (#22043) Previously, when using `capi` calling convention in foreign declarations, code generator failed to handle const-cualified pointer return types. This resulted in CC toolchain throwing `-Wincompatible-pointer-types-discards-qualifiers` warning. `Foreign.C.Types.ConstPtr` newtype was introduced to handle these cases - special treatment was put in place to generate appropritetly qualified C wrapper that no longer triggers the above mentioned warning. Fixes #22043 - - - - - 040bfdc3 by M Farkas-Dyck at 2022-11-23T21:59:03-05:00 Scrub some no-warning pragmas. - - - - - 178c1fd8 by Vladislav Zavialov at 2022-11-23T21:59:39-05:00 Check if the SDoc starts with a single quote (#22488) This patch fixes pretty-printing of character literals inside promoted lists and tuples. When we pretty-print a promoted list or tuple whose first element starts with a single quote, we want to add a space between the opening bracket and the element: '[True] -- ok '[ 'True] -- ok '['True] -- not ok If we don't add the space, we accidentally produce a character literal '['. Before this patch, pprSpaceIfPromotedTyCon inspected the type as an AST and tried to guess if it would be rendered with a single quote. However, it missed the case when the inner type was itself a character literal: '[ 'x'] -- ok '['x'] -- not ok Instead of adding this particular case, I opted for a more future-proof solution: check the SDoc directly. This way we can detect if the single quote is actually there instead of trying to predict it from the AST. The new function is called spaceIfSingleQuote. - - - - - 11627c42 by Matthew Pickering at 2022-11-23T22:00:15-05:00 notes: Fix references to HPT space leak note Updating this note was missed when updating the HPT to the HUG. Fixes #22477 - - - - - 86ff1523 by Andrei Borzenkov at 2022-11-24T17:24:51-05:00 Convert diagnostics in GHC.Rename.Expr to proper TcRnMessage (#20115) Problem: avoid usage of TcRnMessageUnknown Solution: The following `TcRnMessage` messages has been introduced: TcRnNoRebindableSyntaxRecordDot TcRnNoFieldPunsRecordDot TcRnIllegalStaticExpression TcRnIllegalStaticFormInSplice TcRnListComprehensionDuplicateBinding TcRnEmptyStmtsGroup TcRnLastStmtNotExpr TcRnUnexpectedStatementInContext TcRnIllegalTupleSection TcRnIllegalImplicitParameterBindings TcRnSectionWithoutParentheses Co-authored-by: sheaf <sam.derbyshire at gmail.com> - - - - - d198a19a by Cheng Shao at 2022-11-24T17:25:29-05:00 rts: fix missing Arena.h symbols in RtsSymbols.c It was an unfortunate oversight in !8961 and broke devel2 builds. - - - - - 5943e739 by Bodigrim at 2022-11-25T04:38:28-05:00 Assorted fixes to avoid Data.List.{head,tail} - - - - - 1f1b99b8 by sheaf at 2022-11-25T04:38:28-05:00 Review suggestions for assorted fixes to avoid Data.List.{head,tail} - - - - - 13d627bb by Vladislav Zavialov at 2022-11-25T04:39:04-05:00 Print unticked promoted data constructors (#20531) Before this patch, GHC unconditionally printed ticks before promoted data constructors: ghci> type T = True -- unticked (user-written) ghci> :kind! T T :: Bool = 'True -- ticked (compiler output) After this patch, GHC prints ticks only when necessary: ghci> type F = False -- unticked (user-written) ghci> :kind! F F :: Bool = False -- unticked (compiler output) ghci> data False -- introduce ambiguity ghci> :kind! F F :: Bool = 'False -- ticked by necessity (compiler output) The old behavior can be enabled by -fprint-redundant-promotion-ticks. Summary of changes: * Rename PrintUnqualified to NamePprCtx * Add QueryPromotionTick to it * Consult the GlobalRdrEnv to decide whether to print a tick (see mkPromTick) * Introduce -fprint-redundant-promotion-ticks Co-authored-by: Artyom Kuznetsov <hi at wzrd.ht> - - - - - d10dc6bd by Simon Peyton Jones at 2022-11-25T22:31:27+00:00 Fix decomposition of TyConApps Ticket #22331 showed that we were being too eager to decompose a Wanted TyConApp, leading to incompleteness in the solver. To understand all this I ended up doing a substantial rewrite of the old Note [Decomposing equalities], now reborn as Note [Decomposing TyConApp equalities]. Plus rewrites of other related Notes. The actual fix is very minor and actually simplifies the code: in `can_decompose` in `GHC.Tc.Solver.Canonical.canTyConApp`, we now call `noMatchableIrreds`. A closely related refactor: we stop trying to use the same "no matchable givens" function here as in `matchClassInst`. Instead split into two much simpler functions. - - - - - 2da5c38a by Will Hawkins at 2022-11-26T04:05:04-05:00 Redirect output of musttail attribute test Compilation output from test for support of musttail attribute leaked to the console. - - - - - 0eb1c331 by Cheng Shao at 2022-11-28T08:55:53+00:00 Move hs_mulIntMayOflo cbits to ghc-prim It's only used by wasm NCG at the moment, but ghc-prim is a more reasonable place for hosting out-of-line primops. Also, we only need a single version of hs_mulIntMayOflo. - - - - - 36b53a9d by Cheng Shao at 2022-11-28T09:05:57+00:00 compiler: generate ccalls for clz/ctz/popcnt in wasm NCG We used to generate a single wasm clz/ctz/popcnt opcode, but it's wrong when it comes to subwords, so might as well generate ccalls for them. See #22470 for details. - - - - - d4134e92 by Cheng Shao at 2022-11-28T23:48:14-05:00 compiler: remove unused MO_U_MulMayOflo We actually only emit MO_S_MulMayOflo and never emit MO_U_MulMayOflo anywhere. - - - - - 8d15eadc by Apoorv Ingle at 2022-11-29T03:09:31-05:00 Killing cc_fundeps, streamlining kind equality orientation, and type equality processing order Fixes: #217093 Associated to #19415 This change * Flips the orientation of the the generated kind equality coercion in canEqLHSHetero; * Removes `cc_fundeps` in CDictCan as the check was incomplete; * Changes `canDecomposableTyConAppOk` to ensure we process kind equalities before type equalities and avoiding a call to `canEqLHSHetero` while processing wanted TyConApp equalities * Adds 2 new tests for validating the change - testsuites/typecheck/should_compile/T21703.hs and - testsuites/typecheck/should_fail/T19415b.hs (a simpler version of T19415.hs) * Misc: Due to the change in the equality direction some error messages now have flipped type mismatch errors * Changes in Notes: - Note [Fundeps with instances, and equality orientation] supercedes Note [Fundeps with instances] - Added Note [Kind Equality Orientation] to visualize the kind flipping - Added Note [Decomposing Dependent TyCons and Processing Wanted Equalties] - - - - - 646969d4 by Krzysztof Gogolewski at 2022-11-29T03:10:13-05:00 Change printing of sized literals to match the proposal Literals in Core were printed as e.g. 0xFF#16 :: Int16#. The proposal 451 now specifies syntax 0xFF#Int16. This change affects the Core printer only - more to be done later. Part of #21422. - - - - - 02e282ec by Simon Peyton Jones at 2022-11-29T03:10:48-05:00 Be a bit more selective about floating bottoming expressions This MR arranges to float a bottoming expression to the top only if it escapes a value lambda. See #22494 and Note [Floating to the top] in SetLevels. This has a generally beneficial effect in nofib +-------------------------------++----------+ | ||tsv (rel) | +===============================++==========+ | imaginary/paraffins || -0.93% | | imaginary/rfib || -0.05% | | real/fem || -0.03% | | real/fluid || -0.01% | | real/fulsom || +0.05% | | real/gamteb || -0.27% | | real/gg || -0.10% | | real/hidden || -0.01% | | real/hpg || -0.03% | | real/scs || -11.13% | | shootout/k-nucleotide || -0.01% | | shootout/n-body || -0.08% | | shootout/reverse-complement || -0.00% | | shootout/spectral-norm || -0.02% | | spectral/fibheaps || -0.20% | | spectral/hartel/fft || -1.04% | | spectral/hartel/solid || +0.33% | | spectral/hartel/wave4main || -0.35% | | spectral/mate || +0.76% | +===============================++==========+ | geom mean || -0.12% | The effect on compile time is generally slightly beneficial Metrics: compile_time/bytes allocated ---------------------------------------------- MultiLayerModulesTH_OneShot(normal) +0.3% PmSeriesG(normal) -0.2% PmSeriesT(normal) -0.1% T10421(normal) -0.1% T10421a(normal) -0.1% T10858(normal) -0.1% T11276(normal) -0.1% T11303b(normal) -0.2% T11545(normal) -0.1% T11822(normal) -0.1% T12150(optasm) -0.1% T12234(optasm) -0.3% T13035(normal) -0.2% T16190(normal) -0.1% T16875(normal) -0.4% T17836b(normal) -0.2% T17977(normal) -0.2% T17977b(normal) -0.2% T18140(normal) -0.1% T18282(normal) -0.1% T18304(normal) -0.2% T18698a(normal) -0.1% T18923(normal) -0.1% T20049(normal) -0.1% T21839r(normal) -0.1% T5837(normal) -0.4% T6048(optasm) +3.2% BAD T9198(normal) -0.2% T9630(normal) -0.1% TcPlugin_RewritePerf(normal) -0.4% hard_hole_fits(normal) -0.1% geo. mean -0.0% minimum -0.4% maximum +3.2% The T6048 outlier is hard to pin down, but it may be the effect of reading in more interface files definitions. It's a small program for which compile time is very short, so I'm not bothered about it. Metric Increase: T6048 - - - - - ab23dc5e by Ben Gamari at 2022-11-29T03:11:25-05:00 testsuite: Mark unpack_sums_6 as fragile due to #22504 This test is explicitly dependent upon runtime, which is generally not appropriate given that the testsuite is run in parallel and generally saturates the CPU. - - - - - def47dd3 by Ben Gamari at 2022-11-29T03:11:25-05:00 testsuite: Don't use grep -q in unpack_sums_7 `grep -q` closes stdin as soon as it finds the pattern it is looking for, resulting in #22484. - - - - - cc25d52e by Sylvain Henry at 2022-11-29T09:44:31+01:00 Add Javascript backend Add JS backend adapted from the GHCJS project by Luite Stegeman. Some features haven't been ported or implemented yet. Tests for these features have been disabled with an associated gitlab ticket. Bump array submodule Work funded by IOG. Co-authored-by: Jeffrey Young <jeffrey.young at iohk.io> Co-authored-by: Luite Stegeman <stegeman at gmail.com> Co-authored-by: Josh Meredith <joshmeredith2008 at gmail.com> - - - - - 68c966cd by sheaf at 2022-11-30T09:31:25-05:00 Fix @since annotations on WithDict and Coercible Fixes #22453 - - - - - a3a8e9e9 by Simon Peyton Jones at 2022-11-30T09:32:03-05:00 Be more careful in GHC.Tc.Solver.Interact.solveOneFromTheOther We were failing to account for the cc_pend_sc flag in this important function, with the result that we expanded superclasses forever. Fixes #22516. - - - - - a9d9b8c0 by Simon Peyton Jones at 2022-11-30T09:32:03-05:00 Use mkNakedFunTy in tcPatSynSig As #22521 showed, in tcPatSynSig we make a "fake type" to kind-generalise; and that type has unzonked type variables in it. So we must not use `mkFunTy` (which checks FunTy's invariants) via `mkPhiTy` when building this type. Instead we need to use `mkNakedFunTy`. Easy fix. - - - - - 31462d98 by Andreas Klebinger at 2022-11-30T14:50:58-05:00 Properly cast values when writing/reading unboxed sums. Unboxed sums might store a Int8# value as Int64#. This patch makes sure we keep track of the actual value type. See Note [Casting slot arguments] for the details. - - - - - 10a2a7de by Oleg Grenrus at 2022-11-30T14:51:39-05:00 Move Void to GHC.Base... This change would allow `Void` to be used deeper in module graph. For example exported from `Prelude` (though that might be already possible). Also this change includes a change `stimes @Void _ x = x`, https://github.com/haskell/core-libraries-committee/issues/95 While the above is not required, maintaining old stimes behavior would be tricky as `GHC.Base` doesn't know about `Num` or `Integral`, which would require more hs-boot files. - - - - - b4cfa8e2 by Sebastian Graf at 2022-11-30T14:52:24-05:00 DmdAnal: Reflect the `seq` of strict fields of a DataCon worker (#22475) See the updated `Note [Data-con worker strictness]` and the new `Note [Demand transformer for data constructors]`. Fixes #22475. - - - - - d87f28d8 by Baldur Blöndal at 2022-11-30T21:16:36+01:00 Make Functor a quantified superclass of Bifunctor. See https://github.com/haskell/core-libraries-committee/issues/91 for discussion. This change relates Bifunctor with Functor by requiring second = fmap. Moreover this change is a step towards unblocking the major version bump of bifunctors and profunctors to major version 6. This paves the way to move the Profunctor class into base. For that Functor first similarly becomes a superclass of Profunctor in the new major version 6. - - - - - 72cf4c5d by doyougnu at 2022-12-01T12:36:44-05:00 FastString: SAT bucket_match Metric Decrease: MultiLayerModulesTH_OneShot - - - - - afc2540d by Simon Peyton Jones at 2022-12-01T12:37:20-05:00 Add a missing varToCoreExpr in etaBodyForJoinPoint This subtle bug showed up when compiling a library with 9.4. See #22491. The bug is present in master, but it is hard to trigger; the new regression test T22491 fails in 9.4. The fix was easy: just add a missing varToCoreExpr in etaBodyForJoinPoint. The fix is definitely right though! I also did some other minor refatoring: * Moved the preInlineUnconditionally test in simplExprF1 to before the call to joinPointBinding_maybe, to avoid fruitless eta-expansion. * Added a boolean from_lam flag to simplNonRecE, to avoid two fruitless tests, and commented it a bit better. These refactorings seem to save 0.1% on compile-time allocation in perf/compiler; with a max saving of 1.4% in T9961 Metric Decrease: T9961 - - - - - 81eeec7f by M Farkas-Dyck at 2022-12-01T12:37:56-05:00 CI: Forbid the fully static build on Alpine to fail. To do so, we mark some tests broken in this configuration. - - - - - c5d1bf29 by Bryan Richter at 2022-12-01T12:37:56-05:00 CI: Remove ARMv7 jobs These jobs fail (and are allowed to fail) nearly every time. Soon they won't even be able to run at all, as we won't currently have runners that can run them. Fixing the latter problem is tracked in #22409. I went ahead and removed all settings and configurations. - - - - - d82992fd by Bryan Richter at 2022-12-01T12:37:56-05:00 CI: Fix CI lint Failure was introduced by conflicting changes to gen_ci.hs that did *not* trigger git conflicts. - - - - - ce126993 by Simon Peyton Jones at 2022-12-02T01:22:12-05:00 Refactor TyCon to have a top-level product This patch changes the representation of TyCon so that it has a top-level product type, with a field that gives the details (newtype, type family etc), #22458. Not much change in allocation, but execution seems to be a bit faster. Includes a change to the haddock submodule to adjust for API changes. - - - - - 74c767df by Matthew Pickering at 2022-12-02T01:22:48-05:00 ApplicativeDo: Set pattern location before running exhaustiveness checker This improves the error messages of the exhaustiveness checker when checking statements which have been moved around with ApplicativeDo. Before: Test.hs:2:3: warning: [GHC-62161] [-Wincomplete-uni-patterns] Pattern match(es) are non-exhaustive In a pattern binding: Patterns of type ‘Maybe ()’ not matched: Nothing | 2 | let x = () | ^^^^^^^^^^ After: Test.hs:4:3: warning: [GHC-62161] [-Wincomplete-uni-patterns] Pattern match(es) are non-exhaustive In a pattern binding: Patterns of type ‘Maybe ()’ not matched: Nothing | 4 | ~(Just res1) <- seq x (pure $ Nothing @()) | Fixes #22483 - - - - - 85ecc1a0 by Matthew Pickering at 2022-12-02T19:46:43-05:00 Add special case for :Main module in `GHC.IfaceToCore.mk_top_id` See Note [Root-main Id] The `:Main` special binding is actually defined in the current module (hence don't go looking for it externally) but the module name is rOOT_MAIN rather than the current module so we need this special case. There was already some similar logic in `GHC.Rename.Env` for External Core, but now the "External Core" is in interface files it needs to be moved here instead. Fixes #22405 - - - - - 108c319f by Krzysztof Gogolewski at 2022-12-02T19:47:18-05:00 Fix linearity checking in Lint Lint was not able to see that x*y <= x*y, because this inequality was decomposed to x <= x*y && y <= x*y, but there was no rule to see that x <= x*y. Fixes #22546. - - - - - bb674262 by Bryan Richter at 2022-12-03T04:38:46-05:00 Mark T16916 fragile See https://gitlab.haskell.org/ghc/ghc/-/issues/16966 - - - - - 5d267d46 by Vladislav Zavialov at 2022-12-03T04:39:22-05:00 Refactor: FreshOrReuse instead of addTyClTyVarBinds This is a refactoring that should have no effect on observable behavior. Prior to this change, GHC.HsToCore.Quote contained a few closely related functions to process type variable bindings: addSimpleTyVarBinds, addHsTyVarBinds, addQTyVarBinds, and addTyClTyVarBinds. We can classify them by their input type and name generation strategy: Fresh names only Reuse bound names +---------------------+-------------------+ [Name] | addSimpleTyVarBinds | | [LHsTyVarBndr flag GhcRn] | addHsTyVarBinds | | LHsQTyVars GhcRn | addQTyVarBinds | addTyClTyVarBinds | +---------------------+-------------------+ Note how two functions are missing. Because of this omission, there were two places where a LHsQTyVars value was constructed just to be able to pass it to addTyClTyVarBinds: 1. mk_qtvs in addHsOuterFamEqnTyVarBinds -- bad 2. mkHsQTvs in repFamilyDecl -- bad This prevented me from making other changes to LHsQTyVars, so the main goal of this refactoring is to get rid of those workarounds. The most direct solution would be to define the missing functions. But that would lead to a certain amount of code duplication. To avoid code duplication, I factored out the name generation strategy into a function parameter: data FreshOrReuse = FreshNamesOnly | ReuseBoundNames addSimpleTyVarBinds :: FreshOrReuse -> ... addHsTyVarBinds :: FreshOrReuse -> ... addQTyVarBinds :: FreshOrReuse -> ... - - - - - c189b831 by Vladislav Zavialov at 2022-12-03T04:39:22-05:00 addHsOuterFamEqnTyVarBinds: use FreshNamesOnly for explicit binders Consider this example: [d| instance forall a. C [a] where type forall b. G [a] b = Proxy b |] When we process "forall b." in the associated type instance, it is unambiguously the binding site for "b" and we want a fresh name for it. Therefore, FreshNamesOnly is more fitting than ReuseBoundNames. This should not have any observable effect but it avoids pointless lookups in the MetaEnv. - - - - - 42512264 by Ross Paterson at 2022-12-03T10:32:45+00:00 Handle type data declarations in Template Haskell quotations and splices (fixes #22500) This adds a TypeDataD constructor to the Template Haskell Dec type, and ensures that the constructors it contains go in the TyCls namespace. - - - - - 1a767fa3 by Vladislav Zavialov at 2022-12-05T05:18:50-05:00 Add BufSpan to EpaLocation (#22319, #22558) The key part of this patch is the change to mkTokenLocation: - mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r) + mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb) mkTokenLocation used to discard the BufSpan, but now it is saved and can be retrieved from LHsToken or LHsUniToken. This is made possible by the following change to EpaLocation: - data EpaLocation = EpaSpan !RealSrcSpan + data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan) | ... The end goal is to make use of the BufSpan in Parser/PostProcess/Haddock. - - - - - cd31acad by sheaf at 2022-12-06T15:45:58-05:00 Hadrian: fix ghcDebugAssertions off-by-one error Commit 6b2f7ffe changed the logic that decided whether to enable debug assertions. However, it had an off-by-one error, as the stage parameter to the function inconsistently referred to the stage of the compiler being used to build or the stage of the compiler we are building. This patch makes it consistent. Now the parameter always refers to the the compiler which is being built. In particular, this patch re-enables assertions in the stage 2 compiler when building with devel2 flavour, and disables assertions in the stage 2 compiler when building with validate flavour. Some extra performance tests are now run in the "validate" jobs because the stage2 compiler no longer contains assertions. ------------------------- Metric Decrease: CoOpt_Singletons MultiComponentModules MultiComponentModulesRecomp MultiLayerModulesTH_OneShot T11374 T12227 T12234 T13253-spj T13701 T14683 T14697 T15703 T17096 T17516 T18304 T18478 T18923 T5030 T9872b TcPlugin_RewritePerf Metric Increase: MultiComponentModules MultiComponentModulesRecomp MultiLayerModules MultiLayerModulesRecomp MultiLayerModulesTH_Make T13386 T13719 T3294 T9233 T9675 parsing001 ------------------------- - - - - - 21d66db1 by mrkun at 2022-12-06T15:46:38-05:00 Push DynFlags out of runInstallNameTool - - - - - aaaaa79b by mrkun at 2022-12-06T15:46:38-05:00 Push DynFlags out of askOtool - - - - - 4e28f49e by mrkun at 2022-12-06T15:46:38-05:00 Push DynFlags out of runInjectRPaths - - - - - a7422580 by mrkun at 2022-12-06T15:46:38-05:00 Push DynFlags out of Linker.MacOS - - - - - e902d771 by Matthew Craven at 2022-12-08T08:30:23-05:00 Fix bounds-checking buglet in Data.Array.Byte ...another manifestation of #20851 which I unfortunately missed in my first pass. - - - - - 8d36c0c6 by Gergő Érdi at 2022-12-08T08:31:03-05:00 Remove copy-pasted definitions of `graphFromEdgedVertices*` - - - - - c5d8ed3a by Gergő Érdi at 2022-12-08T08:31:03-05:00 Add version of `reachableGraph` that avoids loop for cyclic inputs by building its result connected component by component Fixes #22512 - - - - - 90cd5396 by Krzysztof Gogolewski at 2022-12-08T08:31:39-05:00 Mark Type.Reflection.Unsafe as Unsafe This module can be used to construct ill-formed TypeReps, so it should be Unsafe. - - - - - 2057c77d by Ian-Woo Kim at 2022-12-08T08:32:19-05:00 Truncate eventlog event for large payload (#20221) RTS eventlog events for postCapsetVecEvent are truncated if payload is larger than EVENT_PAYLOAD_SIZE_MAX Previously, postCapsetVecEvent records eventlog event with payload of variable size larger than EVENT_PAYLOAD_SIZE_MAX (2^16) without any validation, resulting in corrupted data. For example, this happens when a Haskell binary is invoked with very long command line arguments exceeding 2^16 bytes (see #20221). Now we check the size of accumulated payload messages incrementally, and truncate the message just before the payload size exceeds EVENT_PAYLOAD_SIZE_MAX. RTS will warn the user with a message showing how many arguments are truncated. - - - - - 9ec76f61 by Cheng Shao at 2022-12-08T08:32:59-05:00 hadrian: don't add debug info to non-debug ways of rts Hadrian used to pass -g when building all ways of rts. It makes output binaries larger (especially so for wasm backend), and isn't needed by most users out there, so this patch removes that flag. In case the debug info is desired, we still pass -g3 when building the debug way, and there's also the debug_info flavour transformer which ensures -g3 is passed for all rts ways. - - - - - 7658cdd4 by Krzysztof Gogolewski at 2022-12-08T08:33:36-05:00 Restore show (typeRep @[]) == "[]" The Show instance for TypeRep [] has changed in 9.5 to output "List" because the name of the type constructor changed. This seems to be accidental and is inconsistent with TypeReps of saturated lists, which are printed as e.g. "[Int]". For now, I'm restoring the old behavior; in the future, maybe we should show TypeReps without puns (List, Tuple, Type). - - - - - 216deefd by Matthew Pickering at 2022-12-08T22:45:27-05:00 Add test for #22162 - - - - - 5d0a311f by Matthew Pickering at 2022-12-08T22:45:27-05:00 ci: Add job to test interface file determinism guarantees In this job we can run on every commit we add a test which builds the Cabal library twice and checks that the ABI hash and interface hash is stable across the two builds. * We run the test 20 times to try to weed out any race conditions due to `-j` * We run the builds in different temporary directories to try to weed out anything related to build directory affecting ABI or interface file hash. Fixes #22180 - - - - - 0a76d7d4 by Matthew Pickering at 2022-12-08T22:45:27-05:00 ci: Add job for testing interface stability across builds The idea is that both the bindists should product libraries with the same ABI and interface hash. So the job checks with ghc-pkg to make sure the computed ABI is the same. In future this job can be extended to check for the other facets of interface determinism. Fixes #22180 - - - - - 74c9bf91 by Matthew Pickering at 2022-12-08T22:45:27-05:00 backpack: Be more careful when adding together ImportAvails There was some code in the signature merging logic which added together the ImportAvails of the signature and the signature which was merged into it. This had the side-effect of making the merged signature depend on the signature (via a normal module dependency). The intention was to propagate orphan instances through the merge but this also messed up recompilation logic because we shouldn't be attempting to load B.hi when mergeing it. The fix is to just combine the part of ImportAvails that we intended to (transitive info, orphan instances and type family instances) rather than the whole thing. - - - - - d122e022 by Matthew Pickering at 2022-12-08T22:45:27-05:00 Fix mk_mod_usage_info if the interface file is not already loaded In #22217 it was observed that the order modules are compiled in affects the contents of an interface file. This was because a module dependended on another module indirectly, via a re-export but the interface file for this module was never loaded because the symbol was never used in the file. If we decide that we depend on a module then we jolly well ought to record this fact in the interface file! Otherwise it could lead to very subtle recompilation bugs if the dependency is not tracked and the module is updated. Therefore the best thing to do is just to make sure the file is loaded by calling the `loadSysInterface` function. This first checks the caches (like we did before) but then actually goes to find the interface on disk if it wasn't loaded. Fixes #22217 - - - - - ea25088d by lrzlin at 2022-12-08T22:46:06-05:00 Add initial support for LoongArch Architecture. - - - - - 9eb9d2f4 by Bodigrim at 2022-12-08T22:46:47-05:00 Update submodule mtl to 2.3.1, parsec to 3.1.15.1, haddock and Cabal to HEAD - - - - - 08d8fe2a by Bodigrim at 2022-12-08T22:46:47-05:00 Allow mtl-2.3 in hadrian - - - - - 3807a46c by Bodigrim at 2022-12-08T22:46:47-05:00 Support mtl-2.3 in check-exact - - - - - ef702a18 by Bodigrim at 2022-12-08T22:46:47-05:00 Fix tests - - - - - 3144e8ff by Sebastian Graf at 2022-12-08T22:47:22-05:00 Make (^) INLINE (#22324) So that we get to cancel away the allocation for the lazily used base. We can move `powImpl` (which *is* strict in the base) to the top-level so that we don't duplicate too much code and move the SPECIALISATION pragmas onto `powImpl`. The net effect of this change is that `(^)` plays along much better with inlining thresholds and loopification (#22227), for example in `x2n1`. Fixes #22324. - - - - - 1d3a8b8e by Matthew Pickering at 2022-12-08T22:47:59-05:00 Typeable: Fix module locations of some definitions in GHC.Types There was some confusion in Data.Typeable about which module certain wired-in things were defined in. Just because something is wired-in doesn't mean it comes from GHC.Prim, in particular things like LiftedRep and RuntimeRep are defined in GHC.Types and that's the end of the story. Things like Int#, Float# etc are defined in GHC.Prim as they have no Haskell definition site at all so we need to generate type representations for them (which live in GHC.Types). Fixes #22510 - - - - - 0f7588b5 by Sebastian Graf at 2022-12-08T22:48:34-05:00 Make `drop` and `dropWhile` fuse (#18964) I copied the fusion framework we have in place for `take`. T18964 asserts that we regress neither when fusion fires nor when it doesn't. Fixes #18964. - - - - - 26e71562 by Sebastian Graf at 2022-12-08T22:49:10-05:00 Do not strictify a DFun's parameter dictionaries (#22549) ... thus fixing #22549. The details are in the refurbished and no longer dead `Note [Do not strictify a DFun's parameter dictionaries]`. There's a regression test in T22549. - - - - - 36093407 by John Ericson at 2022-12-08T22:49:45-05:00 Delete `rts/package.conf.in` It is a relic of the Make build system. The RTS now uses a `package.conf` file generated the usual way by Cabal. - - - - - b0cc2fcf by Krzysztof Gogolewski at 2022-12-08T22:50:21-05:00 Fixes around primitive literals * The SourceText of primitive characters 'a'# did not include the #, unlike for other primitive literals 1#, 1##, 1.0#, 1.0##, "a"#. We can now remove the function pp_st_suffix, which was a hack to add the # back. * Negative primitive literals shouldn't use parentheses, as described in Note [Printing of literals in Core]. Added a testcase to T14681. - - - - - aacf616d by Bryan Richter at 2022-12-08T22:50:56-05:00 testsuite: Mark conc024 fragile on Windows - - - - - ed239a24 by Ryan Scott at 2022-12-09T09:42:16-05:00 Document TH splices' interaction with INCOHERENT instances Top-level declaration splices can having surprising interactions with `INCOHERENT` instances, as observed in #22492. This patch resolves #22492 by documenting this strange interaction in the GHC User's Guide. [ci skip] - - - - - 1023b432 by Mike Pilgrem at 2022-12-09T09:42:56-05:00 Fix #22300 Document GHC's extensions to valid whitespace - - - - - 79b0cec0 by Luite Stegeman at 2022-12-09T09:43:38-05:00 Add support for environments that don't have setImmediate - - - - - 5b007ec5 by Luite Stegeman at 2022-12-09T09:43:38-05:00 Fix bound thread status - - - - - 65335d10 by Matthew Pickering at 2022-12-09T20:15:45-05:00 Update containers submodule This contains a fix necessary for the multi-repl to work on GHC's code base where we try to load containers and template-haskell into the same session. - - - - - 4937c0bb by Matthew Pickering at 2022-12-09T20:15:45-05:00 hadrian-multi: Put interface files in separate directories Before we were putting all the interface files in the same directory which was leading to collisions if the files were called the same thing. - - - - - 8acb5b7b by Matthew Pickering at 2022-12-09T20:15:45-05:00 hadrian-toolargs: Add filepath to allowed repl targets - - - - - 5949d927 by Matthew Pickering at 2022-12-09T20:15:45-05:00 driver: Set correct UnitId when rehydrating modules We were not setting the UnitId before rehydrating modules which just led to us attempting to find things in the wrong HPT. The test for this is the hadrian-multi command (which is now added as a CI job). Fixes #22222 - - - - - ab06c0f0 by Matthew Pickering at 2022-12-09T20:15:45-05:00 ci: Add job to test hadrian-multi command I am not sure this job is good because it requires booting HEAD with HEAD, but it should be fine. - - - - - fac3e568 by Matthew Pickering at 2022-12-09T20:16:20-05:00 hadrian: Update bootstrap plans to 9.2.* series and 9.4.* series. This updates the build plans for the most recent compiler versions, as well as fixing the hadrian-bootstrap-gen script to a specific GHC version. - - - - - 195b08b4 by Matthew Pickering at 2022-12-09T20:16:20-05:00 ci: Bump boot images to use ghc-9.4.3 Also updates the bootstrap jobs to test booting 9.2 and 9.4. - - - - - c658c580 by Matthew Pickering at 2022-12-09T20:16:20-05:00 hlint: Removed redundant UnboxedSums pragmas UnboxedSums is quite confusingly implied by UnboxedTuples, alas, just the way it is. See #22485 - - - - - b3e98a92 by Oleg Grenrus at 2022-12-11T12:26:17-05:00 Add heqT, a kind-heterogeneous variant of heq CLC proposal https://github.com/haskell/core-libraries-committee/issues/99 - - - - - bfd7c1e6 by Bodigrim at 2022-12-11T12:26:55-05:00 Document that Bifunctor instances for tuples are lawful only up to laziness - - - - - 5d1a1881 by Bryan Richter at 2022-12-12T16:22:36-05:00 Mark T21336a fragile - - - - - c30accc2 by Matthew Pickering at 2022-12-12T16:23:11-05:00 Add test for #21476 This issues seems to have been fixed since the ticket was made, so let's add a test and move on. Fixes #21476 - - - - - e9d74a3e by Sebastian Graf at 2022-12-13T22:18:39-05:00 Respect -XStrict in the pattern-match checker (#21761) We were missing a call to `decideBangHood` in the pattern-match checker. There is another call in `matchWrapper.mk_eqn_info` which seems redundant but really is not; see `Note [Desugaring -XStrict matches in Pmc]`. Fixes #21761. - - - - - 884790e2 by Gergő Érdi at 2022-12-13T22:19:14-05:00 Fix loop in the interface representation of some `Unfolding` fields As discovered in #22272, dehydration of the unfolding info of a recursive definition used to involve a traversal of the definition itself, which in turn involves traversing the unfolding info. Hence, a loop. Instead, we now store enough data in the interface that we can produce the unfolding info without this traversal. See Note [Tying the 'CoreUnfolding' knot] for details. Fixes #22272 Co-authored-by: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - 9f301189 by Alan Zimmerman at 2022-12-13T22:19:50-05:00 EPA: When splitting out header comments, keep ones for first decl Any comments immediately preceding the first declaration are no longer kept as header comments, but attach to the first declaration instead. - - - - - 8b1f1b45 by Sylvain Henry at 2022-12-13T22:20:28-05:00 JS: fix object file name comparison (#22578) - - - - - e9e161bb by Bryan Richter at 2022-12-13T22:21:03-05:00 configure: Bump min bootstrap GHC version to 9.2 - - - - - 75855643 by Ben Gamari at 2022-12-15T03:54:02-05:00 hadrian: Don't enable TSAN in stage0 build - - - - - da7b51d8 by Ben Gamari at 2022-12-15T03:54:02-05:00 cmm: Introduce blockConcat - - - - - 34f6b09c by Ben Gamari at 2022-12-15T03:54:02-05:00 cmm: Introduce MemoryOrderings - - - - - 43beaa7b by Ben Gamari at 2022-12-15T03:54:02-05:00 llvm: Respect memory specified orderings - - - - - 8faf74fc by Ben Gamari at 2022-12-15T03:54:02-05:00 Codegen/x86: Eliminate barrier for relaxed accesses - - - - - 6cc3944a by Ben Gamari at 2022-12-15T03:54:02-05:00 cmm/Parser: Reduce some repetition - - - - - 6c9862c4 by Ben Gamari at 2022-12-15T03:54:02-05:00 cmm/Parser: Add syntax for ordered loads and stores - - - - - 748490d2 by Ben Gamari at 2022-12-15T03:54:02-05:00 cmm/Parser: Atomic load syntax Originally I had thought I would just use the `prim` call syntax instead of introducing new syntax for atomic loads. However, it turns out that `prim` call syntax tends to make things quite unreadable. This new syntax seems quite natural. - - - - - 28c6781a by Ben Gamari at 2022-12-15T03:54:02-05:00 codeGen: Introduce ThreadSanitizer instrumentation This introduces a new Cmm pass which instruments the program with ThreadSanitizer annotations, allowing full tracking of mutator memory accesses via TSAN. - - - - - d97aa311 by Ben Gamari at 2022-12-15T03:54:02-05:00 Hadrian: Drop TSAN_ENABLED define from flavour This is redundant since the TSANUtils.h already defines it. - - - - - 86974ef1 by Ben Gamari at 2022-12-15T03:54:02-05:00 hadrian: Enable Cmm instrumentation in TSAN flavour - - - - - 93723290 by Ben Gamari at 2022-12-15T03:54:02-05:00 rts: Ensure that global regs are never passed as fun call args This is in general unsafe as they may be clobbered if they are mapped to caller-saved machine registers. See Note [Register parameter passing]. - - - - - 2eb0fb87 by Matthew Pickering at 2022-12-15T03:54:39-05:00 Package Imports: Get candidate packages also from re-exported modules Previously we were just looking at the direct imports to try and work out what a package qualifier could apply to but #22333 pointed out we also needed to look for reexported modules. Fixes #22333 - - - - - 552b7908 by Ben Gamari at 2022-12-15T03:55:15-05:00 compiler: Ensure that MutVar operations have necessary barriers Here we add acquire and release barriers in readMutVar# and writeMutVar#, which are necessary for soundness. Fixes #22468. - - - - - 933d61a4 by Simon Peyton Jones at 2022-12-15T03:55:51-05:00 Fix bogus test in Lint The Lint check for branch compatiblity within an axiom, in GHC.Core.Lint.compatible_branches was subtly different to the check made when contructing an axiom, in GHC.Core.FamInstEnv.compatibleBranches. The latter is correct, so I killed the former and am now using the latter. On the way I did some improvements to pretty-printing and documentation. - - - - - 03ed0b95 by Ryan Scott at 2022-12-15T03:56:26-05:00 checkValidInst: Don't expand synonyms when splitting sigma types Previously, the `checkValidInst` function (used when checking that an instance declaration is headed by an actual type class, not a type synonym) was using `tcSplitSigmaTy` to split apart the `forall`s and instance context. This is incorrect, however, as `tcSplitSigmaTy` expands type synonyms, which can cause instances headed by quantified constraint type synonyms to be accepted erroneously. This patch introduces `splitInstTyForValidity`, a variant of `tcSplitSigmaTy` specialized for validity checking that does _not_ expand type synonyms, and uses it in `checkValidInst`. Fixes #22570. - - - - - ed056bc3 by Ben Gamari at 2022-12-16T16:12:44-05:00 rts/Messages: Refactor This doesn't change behavior but makes the code a bit easier to follow. - - - - - 7356f8e0 by Ben Gamari at 2022-12-16T16:12:44-05:00 rts/ThreadPaused: Ordering fixes - - - - - 914f0025 by Ben Gamari at 2022-12-16T16:12:44-05:00 eventlog: Silence spurious data race - - - - - fbc84244 by Ben Gamari at 2022-12-16T16:12:44-05:00 Introduce SET_INFO_RELEASE for Cmm - - - - - 821b5472 by Ben Gamari at 2022-12-16T16:12:44-05:00 rts: Use fences instead of explicit barriers - - - - - 2228c999 by Ben Gamari at 2022-12-16T16:12:44-05:00 rts/stm: Fix memory ordering in readTVarIO# See #22421. - - - - - 99269b9f by Ben Gamari at 2022-12-16T16:12:44-05:00 Improve heap memory barrier Note Also introduce MUT_FIELD marker in Closures.h to document mutable fields. - - - - - 70999283 by Ben Gamari at 2022-12-16T16:12:44-05:00 rts: Introduce getNumCapabilities And ensure accesses to n_capabilities are atomic (although with relaxed ordering). This is necessary as RTS API callers may concurrently call into the RTS without holding a capability. - - - - - 98689f77 by Ben Gamari at 2022-12-16T16:12:44-05:00 ghc: Fix data race in dump file handling Previously the dump filename cache would use a non-atomic update which could potentially result in lost dump contents. Note that this is still a bit racy since the first writer may lag behind a later appending writer. - - - - - 605d9547 by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Always use atomics for context_switch and interrupt Since these are modified by the timer handler. - - - - - 86f20258 by Ben Gamari at 2022-12-16T16:12:45-05:00 rts/Timer: Always use atomic operations As noted in #22447, the existence of the pthread-based ITimer implementation means that we cannot assume that the program is single-threaded. - - - - - f8e901dc by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Encapsulate recent_activity access This makes it easier to ensure that it is accessed using the necessary atomic operations. - - - - - e0affaa9 by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Encapsulate access to capabilities array - - - - - 7ca683e4 by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Encapsulate sched_state - - - - - 1cf13bd0 by Ben Gamari at 2022-12-16T16:12:45-05:00 PrimOps: Fix benign MutVar race Relaxed ordering is fine here since the later CAS implies a release. - - - - - 3d2a7e08 by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Style fix - - - - - 82c62074 by Ben Gamari at 2022-12-16T16:12:45-05:00 compiler: Use release store in eager blackholing - - - - - eb1a0136 by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Fix ordering of makeStableName - - - - - ad0e260a by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Use ordered accesses instead of explicit barriers - - - - - a3eccf06 by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Statically allocate capabilities This is a rather simplistic way of solving #17289. - - - - - 287fa3fb by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Ensure that all accesses to pending_sync are atomic - - - - - 351eae58 by Ben Gamari at 2022-12-16T16:12:45-05:00 rts: Note race with wakeBlockingQueue - - - - - 5acf33dd by Bodigrim at 2022-12-16T16:13:22-05:00 Bump submodule directory to 1.3.8.0 and hpc to HEAD - - - - - 0dd95421 by Bodigrim at 2022-12-16T16:13:22-05:00 Accept allocations increase on Windows This is because of `filepath-1.4.100.0` and AFPP, causing increasing round-trips between lists and ByteArray. See #22625 for discussion. Metric Increase: MultiComponentModules MultiComponentModulesRecomp MultiLayerModules MultiLayerModulesRecomp T10421 T10547 T12150 T12227 T12234 T12425 T13035 T13253 T13253-spj T13701 T13719 T15703 T16875 T18140 T18282 T18304 T18698a T18698b T18923 T20049 T21839c T21839r T5837 T6048 T9198 T9961 TcPlugin_RewritePerf hard_hole_fits - - - - - ef9ac9d2 by Cheng Shao at 2022-12-16T16:13:59-05:00 testsuite: Mark T9405 as fragile instead of broken on Windows It's starting to pass again, and the unexpected pass blocks CI. - - - - - 1f3abd85 by Cheng Shao at 2022-12-16T21:16:28+00:00 compiler: remove obsolete commented code in wasm NCG It was just a temporary hack to workaround a bug in the relooper, that bug has been fixed long before the wasm backend is merged. - - - - - e3104eab by Cheng Shao at 2022-12-16T21:16:28+00:00 compiler: add missing export list of GHC.CmmToAsm.Wasm.FromCmm Also removes some unreachable code here. - - - - - 1c6930bf by Cheng Shao at 2022-12-16T21:16:28+00:00 compiler: change fallback function signature to Cmm function signature in wasm NCG In the wasm NCG, when handling a `CLabel` of undefined function without knowing its function signature, we used to fallback to `() -> ()` which is accepted by `wasm-ld`. This patch changes it to the signature of Cmm functions, which equally works, but would be required when we emit tail call instructions. - - - - - 8a81d9d9 by Cheng Shao at 2022-12-16T21:16:28+00:00 compiler: add optional tail-call support in wasm NCG When the `-mtail-call` clang flag is passed at configure time, wasm tail-call extension is enabled, and the wasm NCG will emit `return_call`/`return_call_indirect` instructions to take advantage of it and avoid the `StgRun` trampoline overhead. Closes #22461. - - - - - d1431cc0 by Cheng Shao at 2022-12-17T08:07:15-05:00 base: add missing autoconf checks for waitpid/umask These are not present in wasi-libc. Required for fixing #22589 - - - - - da3f1e91 by Cheng Shao at 2022-12-17T08:07:51-05:00 compiler: make .wasm the default executable extension on wasm32 Following convention as in other wasm toolchains. Fixes #22594. - - - - - ad21f4ef by Cheng Shao at 2022-12-17T08:07:51-05:00 ci: support hello.wasm in ci.sh cross testing logic - - - - - 6fe2d778 by amesgen at 2022-12-18T19:33:49-05:00 Correct `exitWith` Haddocks The `IOError`-specific `catch` in the Prelude is long gone. - - - - - b3eacd64 by Ben Gamari at 2022-12-18T19:34:24-05:00 rts: Drop racy assertion 0e274c39bf836d5bb846f5fa08649c75f85326ac added an assertion in `dirty_MUT_VAR` checking that the MUT_VAR being dirtied was clean. However, this isn't necessarily the case since another thread may have raced us to dirty the object. - - - - - 761c1f49 by Ben Gamari at 2022-12-18T19:35:00-05:00 rts/libdw: Silence uninitialized usage warnings As noted in #22538, previously some GCC versions warned that various locals in Libdw.c may be used uninitialized. Although this wasn't strictly true (since they were initialized in an inline assembler block) we fix this by providing explicit empty initializers. Fixes #22538 - - - - - 5e047eff by Matthew Pickering at 2022-12-20T15:12:04+00:00 testsuite: Mark T16392 as fragile on windows See #22649 - - - - - 703a4665 by M Farkas-Dyck at 2022-12-20T21:14:46-05:00 Scrub some partiality in `GHC.Cmm.Info.Build`: `doSRTs` takes a `[(CAFSet, CmmDecl)]` but truly wants a `[(CAFSet, CmmStatics)]`. - - - - - 9736ab74 by Matthew Pickering at 2022-12-20T21:15:22-05:00 packaging: Fix upload_ghc_libs.py script This change reflects the changes where .cabal files are now generated by hadrian rather than ./configure. Fixes #22518 - - - - - 7c6de18d by Ben Gamari at 2022-12-20T21:15:57-05:00 configure: Drop uses of AC_PROG_CC_C99 As noted in #22566, this macro is deprecated as of autoconf-2.70 `AC_PROG_CC` now sets `ac_cv_prog_cc_c99` itself. Closes #22566. - - - - - 36c5d98e by Ben Gamari at 2022-12-20T21:15:57-05:00 configure: Use AS_HELP_STRING instead of AC_HELP_STRING The latter has been deprecated. See #22566. - - - - - befe6ff8 by Bodigrim at 2022-12-20T21:16:37-05:00 GHCi.UI: fix various usages of head and tail - - - - - 666d0ba7 by Bodigrim at 2022-12-20T21:16:37-05:00 GHCi.UI: avoid head and tail in parseCallEscape and around - - - - - 5d96fd50 by Bodigrim at 2022-12-20T21:16:37-05:00 Make GHC.Driver.Main.hscTcRnLookupRdrName to return NonEmpty - - - - - 3ce2ab94 by Bodigrim at 2022-12-21T06:17:56-05:00 Allow transformers-0.6 in ghc, ghci, ghc-bin and hadrian - - - - - 954de93a by Bodigrim at 2022-12-21T06:17:56-05:00 Update submodule haskeline to HEAD (to allow transformers-0.6) - - - - - cefbeec3 by Bodigrim at 2022-12-21T06:17:56-05:00 Update submodule transformers to 0.6.0.4 - - - - - b4730b62 by Bodigrim at 2022-12-21T06:17:56-05:00 Fix tests T13253 imports MonadTrans, which acquired a quantified constraint in transformers-0.6, thus increase in allocations Metric Increase: T13253 - - - - - 0be75261 by Simon Peyton Jones at 2022-12-21T06:18:32-05:00 Abstract over the right free vars Fix #22459, in two ways: (1) Make the Specialiser not create a bogus specialisation if it is presented by strangely polymorphic dictionary. See Note [Weird special case in SpecDict] in GHC.Core.Opt.Specialise (2) Be more careful in abstractFloats See Note [Which type variables to abstract over] in GHC.Core.Opt.Simplify.Utils. So (2) stops creating the excessively polymorphic dictionary in abstractFloats, while (1) stops crashing if some other pass should nevertheless create a weirdly polymorphic dictionary. - - - - - df7bc6b3 by Ying-Ruei Liang (TheKK) at 2022-12-21T14:31:54-05:00 rts: explicitly store return value of ccall checkClosure to prevent type error (#22617) - - - - - e193e537 by Simon Peyton Jones at 2022-12-21T14:32:30-05:00 Fix shadowing lacuna in OccurAnal Issue #22623 demonstrated another lacuna in the implementation of wrinkle (BS3) in Note [The binder-swap substitution] in the occurrence analyser. I was failing to add TyVar lambda binders using addInScope/addOneInScope and that led to a totally bogus binder-swap transformation. Very easy to fix. - - - - - 3d55d8ab by Simon Peyton Jones at 2022-12-21T14:32:30-05:00 Fix an assertion check in addToEqualCtList The old assertion saw that a constraint ct could rewrite itself (of course it can) and complained (stupid). Fixes #22645 - - - - - ceb2e9b9 by Ben Gamari at 2022-12-21T15:26:08-05:00 configure: Bump version to 9.6 - - - - - fb4d36c4 by Ben Gamari at 2022-12-21T15:27:49-05:00 base: Bump version to 4.18 Requires various submodule bumps. - - - - - 93ee7e90 by Ben Gamari at 2022-12-21T15:27:49-05:00 ghc-boot: Fix bootstrapping - - - - - fc3a2232 by Ben Gamari at 2022-12-22T13:45:06-05:00 Bump GHC version to 9.7 - - - - - 914f7fe3 by Andreas Klebinger at 2022-12-22T23:36:10-05:00 Don't consider large byte arrays/compact regions pinned. Workaround for #22255 which showed how treating large/compact regions as pinned could cause segfaults. - - - - - 32b32d7f by Matthew Pickering at 2022-12-22T23:36:46-05:00 hadrian bindist: Install manpages to share/man/man1/ghc.1 When the installation makefile was copied over the manpages were no longer installed in the correct place. Now we install it into share/man/man1/ghc.1 as the make build system did. Fixes #22371 - - - - - b3ddf803 by Ben Gamari at 2022-12-22T23:37:23-05:00 rts: Drop paths from configure from cabal file A long time ago we would rely on substitutions from the configure script to inject paths of the include and library directories of libffi and libdw. However, now these are instead handled inside Hadrian when calling Cabal's `configure` (see the uses of `cabalExtraDirs` in Hadrian's `Settings.Packages.packageArgs`). While the occurrences in the cabal file were redundant, they did no harm. However, since b5c714545abc5f75a1ffdcc39b4bfdc7cd5e64b4 they have no longer been interpolated. @mpickering noticed the suspicious uninterpolated occurrence of `@FFIIncludeDir@` in #22595, prompting this commit to finally remove them. - - - - - b2c7523d by Ben Gamari at 2022-12-22T23:37:59-05:00 Bump libffi-tarballs submodule We will now use libffi-3.4.4. - - - - - 3699a554 by Alan Zimmerman at 2022-12-22T23:38:35-05:00 EPA: Make EOF position part of AnnsModule Closes #20951 Closes #19697 - - - - - 99757ce8 by Sylvain Henry at 2022-12-22T23:39:13-05:00 JS: fix support for -outputdir (#22641) The `-outputdir` option wasn't correctly handled with the JS backend because the same code path was used to handle both objects produced by the JS backend and foreign .js files. Now we clearly distinguish the two in the pipeline, fixing the bug. - - - - - 02ed7d78 by Simon Peyton Jones at 2022-12-22T23:39:49-05:00 Refactor mkRuntimeError This patch fixes #22634. Because we don't have TYPE/CONSTRAINT polymorphism, we need two error functions rather than one. I took the opportunity to rname runtimeError to impossibleError, to line up with mkImpossibleExpr, and avoid confusion with the genuine runtime-error-constructing functions. - - - - - 35267f07 by Ben Gamari at 2022-12-22T23:40:32-05:00 base: Fix event manager shutdown race on non-Linux platforms During shutdown it's possible that we will attempt to use a closed fd to wakeup another capability's event manager. On the Linux eventfd path we were careful to handle this. However on the non-Linux path we failed to do so. Fix this. - - - - - 317f45c1 by Simon Peyton Jones at 2022-12-22T23:41:07-05:00 Fix unifier bug: failing to decompose over-saturated type family This simple patch fixes #22647 - - - - - 14b2e3d3 by Ben Gamari at 2022-12-22T23:41:42-05:00 rts/m32: Fix sanity checking Previously we would attempt to clear pages which were marked as read-only. Fix this. - - - - - 16a1bcd1 by Matthew Pickering at 2022-12-23T09:15:24+00:00 ci: Move wasm pipelines into nightly rather than master See #22664 for the changes which need to be made to bring one of these back to the validate pipeline. - - - - - 18d2acd2 by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Fix race in marking of blackholes We must use an acquire-fence when marking to ensure that the indirectee is visible. - - - - - 11241efa by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Fix segment list races - - - - - 602455c9 by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Use atomic when looking at bd->gen Since it may have been mutated by a moving GC. - - - - - 9d63b160 by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Eliminate race in bump_static_flag To ensure that we don't race with a mutator entering a new CAF we take the SM mutex before touching static_flag. The other option here would be to instead modify newCAF to use a CAS but the present approach is a bit safer. - - - - - 26837523 by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Ensure that mutable fields have acquire barrier - - - - - 8093264a by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Fix races in collector status tracking Mark a number of accesses to do with tracking of the status of the concurrent collection thread as atomic. No interesting races here, merely necessary to satisfy TSAN. - - - - - 387d4fcc by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Make segment state updates atomic - - - - - 543cae00 by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Refactor update remembered set initialization This avoids a lock inversion between the storage manager mutex and the stable pointer table mutex by not dropping the SM_MUTEX in nonmovingCollect. This requires quite a bit of rejiggering but it does seem like a better strategy. - - - - - c9936718 by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Ensure that we aren't holding locks when closing them TSAN complains about this sort of thing. - - - - - 0cd31f7d by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Make bitmap accesses atomic This is a benign race on any sensible hard since these are byte accesses. Nevertheless, atomic accesses are necessary to satisfy TSAN. - - - - - d3fe110a by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Fix benign race in update remembered set check Relaxed load is fine here since we will take the lock before looking at the list. - - - - - ab6cf893 by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Fix race in shortcutting We must use an acquire load to read the info table pointer since if we find an indirection we must be certain that we see the indirectee. - - - - - 36c9f23c by Ben Gamari at 2022-12-23T19:09:30-05:00 nonmoving: Make free list counter accesses atomic Since these may race with the allocator(s). - - - - - aebef31c by doyougnu at 2022-12-23T19:10:09-05:00 add GHC.Utils.Binary.foldGet' and use for Iface A minor optimization to remove lazy IO and a lazy accumulator strictify foldGet' IFace.Binary: use strict foldGet' remove superfluous bang - - - - - 5eb357d9 by Ben Gamari at 2022-12-24T00:41:05-05:00 compiler: Ensure that GHC toolchain is first in search path As noted in #22561, it is important that GHC's toolchain look first for its own headers and libraries to ensure that the system's are not found instead. If this happens things can break in surprising ways (e.g. see #22561). - - - - - cbaebfb9 by Matthew Pickering at 2022-12-24T00:41:40-05:00 head.hackage: Use slow-validate bindist for linting jobs This enables the SLOW_VALIDATE env var for the linting head.hackage jobs, namely the jobs enabled manually, by the label or on the nightly build now use the deb10-numa-slow-validate bindist which has assertions enabled. See #22623 for a ticket which was found by using this configuration already! The head.hackage jobs triggered by upstream CI are now thusly: hackage-lint: Can be triggered on any MR, normal validate pipeline or nightly build. Runs head.hackage with -dlint and a slow-validate bindist hackage-label-lint: Trigged on MRs with "user-facing" label, runs the slow-validate head.hackage build with -dlint. nightly-hackage-lint: Runs automatically on nightly pipelines with slow-validate + dlint config. nightly-hackage-perf: Runs automaticaly on nightly pipelines with release build and eventlogging enabled. release-hackage-lint: Runs automatically on release pipelines with -dlint on a release bindist. - - - - - f4850f36 by Matthew Pickering at 2022-12-24T00:41:40-05:00 ci: Don't run abi-test-nightly on release jobs The test is not configured to get the correct dependencies for the release pipelines (and indeed stops the release pipeline being run at all) - - - - - c264b06b by Matthew Pickering at 2022-12-24T00:41:40-05:00 ci: Run head.hackage jobs on upstream-testing branch rather than master This change allows less priviledged users to trigger head.hackage jobs because less permissions are needed to trigger jobs on the upstream-testing branch, which is not protected. There is a CI job which updates upstream-testing each hour to the state of the master branch so it should always be relatively up-to-date. - - - - - 63b97430 by Ben Gamari at 2022-12-24T00:42:16-05:00 llvmGen: Fix relaxed ordering Previously I used LLVM's `unordered` ordering for the C11 `relaxed` ordering. However, this is wrong and should rather use the LLVM `monotonic` ordering. Fixes #22640 - - - - - f42ba88f by Ben Gamari at 2022-12-24T00:42:16-05:00 gitlab-ci: Introduce aarch64-linux-llvm job This nightly job will ensure that we don't break the LLVM backend on AArch64/Linux by bootstrapping GHC. This would have caught #22640. - - - - - 6d62f6bf by Matthew Pickering at 2022-12-24T00:42:51-05:00 Store RdrName rather than OccName in Holes In #20472 it was pointed out that you couldn't defer out of scope but the implementation collapsed a RdrName into an OccName to stuff it into a Hole. This leads to the error message for a deferred qualified name dropping the qualification which affects the quality of the error message. This commit adds a bit more structure to a hole, so a hole can replace a RdrName without losing information about what that RdrName was. This is important when printing error messages. I also added a test which checks the Template Haskell deferral of out of scope qualified names works properly. Fixes #22130 - - - - - 3c3060e4 by Richard Eisenberg at 2022-12-24T17:34:19+00:00 Drop support for kind constraints. This implements proposal 547 and closes ticket #22298. See the proposal and ticket for motivation. Compiler perf improves a bit Metrics: compile_time/bytes allocated ------------------------------------- CoOpt_Singletons(normal) -2.4% GOOD T12545(normal) +1.0% T13035(normal) -13.5% GOOD T18478(normal) +0.9% T9872d(normal) -2.2% GOOD geo. mean -0.2% minimum -13.5% maximum +1.0% Metric Decrease: CoOpt_Singletons T13035 T9872d - - - - - 6d7d4393 by Ben Gamari at 2022-12-24T21:09:56-05:00 hadrian: Ensure that linker scripts are used when merging objects In #22527 @rui314 inadvertantly pointed out a glaring bug in Hadrian's implementation of the object merging rules: unlike the old `make` build system we utterly failed to pass the needed linker scripts. Fix this. - - - - - a5bd0eb8 by Bodigrim at 2022-12-24T21:10:34-05:00 Document infelicities of instance Ord Double and workarounds - - - - - 62b9a7b2 by Zubin Duggal at 2023-01-03T12:22:11+00:00 Force the Docs structure to prevent leaks in GHCi with -haddock without -fwrite-interface Involves adding many new NFData instances. Without forcing Docs, references to the TcGblEnv for each module are retained by the Docs structure. Usually these are forced when the ModIface is serialised but not when we aren't writing the interface. - - - - - 21bedd84 by Facundo Domínguez at 2023-01-03T23:27:30-05:00 Explain the auxiliary functions of permutations - - - - - 32255d05 by Matthew Pickering at 2023-01-04T11:58:42+00:00 compiler: Add -f[no-]split-sections flags Here we add a `-fsplit-sections` flag which may some day replace `-split-sections`. This has the advantage of automatically providing a `-fno-split-sections` flag, which is useful for our packaging because we enable `-split-sections` by default but want to disable it in certain configurations. - - - - - e640940c by Matthew Pickering at 2023-01-04T11:58:42+00:00 hadrian: Fix computation of tables_next_to_code for outOfTreeCompiler This copy-pasto was introduced in de5fb3489f2a9bd6dc75d0cb8925a27fe9b9084b - - - - - 15bee123 by Matthew Pickering at 2023-01-04T11:58:42+00:00 hadrian: Add test:all_deps to build just testsuite dependencies Fixes #22534 - - - - - fec6638e by Matthew Pickering at 2023-01-04T11:58:42+00:00 hadrian: Add no_split_sections tranformer This transformer reverts the effect of `split_sections`, which we intend to use for platforms which don't support split sections. In order to achieve this we have to modify the implemntation of the split_sections transformer to store whether we are enabling split_sections directly in the `Flavour` definition. This is because otherwise there's no convenient way to turn off split_sections due to having to pass additional linker scripts when merging objects. - - - - - 3dc05726 by Matthew Pickering at 2023-01-04T11:58:42+00:00 check-exact: Fix build with -Werror - - - - - 53a6ae7a by Matthew Pickering at 2023-01-04T11:58:42+00:00 ci: Build all test dependencies with in-tree compiler This means that these executables will honour flavour transformers such as "werror". Fixes #22555 - - - - - 32e264c1 by Matthew Pickering at 2023-01-04T11:58:42+00:00 hadrian: Document using GHC environment variable to select boot compiler Fixes #22340 - - - - - be9dd9b0 by Matthew Pickering at 2023-01-04T11:58:42+00:00 packaging: Build perf builds with -split-sections In 8f71d958 the make build system was made to use split-sections on linux systems but it appears this logic never made it to hadrian. There is the split_sections flavour transformer but this doesn't appear to be used for perf builds on linux. This is disbled on deb9 and windows due to #21670 Closes #21135 - - - - - 00dc5106 by Matthew Pickering at 2023-01-04T14:32:45-05:00 sphinx: Use modern syntax for extlinks This fixes the following build error: ``` Command line: /opt/homebrew/opt/sphinx-doc/bin/sphinx-build -b man -d /private/tmp/extra-dir-55768274273/.doctrees-man -n -w /private/tmp/extra-dir-55768274273/.log docs/users_guide /private/tmp/extra-dir-55768274273 ===> Command failed with error code: 2 Exception occurred: File "/opt/homebrew/Cellar/sphinx-doc/6.0.0/libexec/lib/python3.11/site-packages/sphinx/ext/extlinks.py", line 101, in role title = caption % part ~~~~~~~~^~~~~~ TypeError: not all arguments converted during string formatting ``` I tested on Sphinx-5.1.1 and Sphinx-6.0.0 Thanks for sterni for providing instructions about how to test using sphinx-6.0.0. Fixes #22690 - - - - - 541aedcd by Krzysztof Gogolewski at 2023-01-05T10:48:34-05:00 Misc cleanup - Remove unused uniques and hs-boot declarations - Fix types of seq and unsafeCoerce# - Remove FastString/String roundtrip in JS - Use TTG to enforce totality - Remove enumeration in Heap/Inspect; the 'otherwise' clause serves the primitive types well. - - - - - 22bb8998 by Alan Zimmerman at 2023-01-05T10:49:09-05:00 EPA: Do not collect comments from end of file In Parser.y semis1 production triggers for the virtual semi at the end of the file. This is detected by it being zero length. In this case, do not extend the span being used to gather comments, so any final comments are allocated at the module level instead. - - - - - 9e077999 by Vladislav Zavialov at 2023-01-05T23:01:55-05:00 HsToken in TypeArg (#19623) Updates the haddock submodule. - - - - - b2a2db04 by Matthew Pickering at 2023-01-05T23:02:30-05:00 Revert "configure: Drop uses of AC_PROG_CC_C99" This reverts commit 7c6de18dd3151ead954c210336728e8686c91de6. Centos7 using a very old version of the toolchain (autotools-2.69) where the behaviour of these macros has not yet changed. I am reverting this without haste as it is blocking the 9.6 branch. Fixes #22704 - - - - - 28f8c0eb by Luite Stegeman at 2023-01-06T18:16:24+09:00 Add support for sized literals in the bytecode interpreter. The bytecode interpreter only has branching instructions for word-sized values. These are used for pattern matching. Branching instructions for other types (e.g. Int16# or Word8#) weren't needed, since unoptimized Core or STG never requires branching on types like this. It's now possible for optimized STG to reach the bytecode generator (e.g. fat interface files or certain compiler flag combinations), which requires dealing with various sized literals in branches. This patch improves support for generating bytecode from optimized STG by adding the following new bytecode instructions: TESTLT_I64 TESTEQ_I64 TESTLT_I32 TESTEQ_I32 TESTLT_I16 TESTEQ_I16 TESTLT_I8 TESTEQ_I8 TESTLT_W64 TESTEQ_W64 TESTLT_W32 TESTEQ_W32 TESTLT_W16 TESTEQ_W16 TESTLT_W8 TESTEQ_W8 Fixes #21945 - - - - - ac39e8e9 by Matthew Pickering at 2023-01-06T13:47:00-05:00 Only store Name in FunRhs rather than Id with knot-tied fields All the issues here have been caused by #18758. The goal of the ticket is to be able to talk about things like `LTyClDecl GhcTc`. In the case of HsMatchContext, the correct "context" is whatever we want, and in fact storing just a `Name` is sufficient and correct context, even if the rest of the AST is storing typechecker Ids. So this reverts (#20415, !5579) which intended to get closed to #18758 but didn't really and introduced a few subtle bugs. Printing of an error message in #22695 would just hang, because we would attempt to print the `Id` in debug mode to assertain whether it was empty or not. Printing the Name is fine for the error message. Another consequence is that when `-dppr-debug` was enabled the compiler would hang because the debug printing of the Id would try and print fields which were not populated yet. This also led to 32070e6c2e1b4b7c32530a9566fe14543791f9a6 having to add a workaround for the `checkArgs` function which was probably a very similar bug to #22695. Fixes #22695 - - - - - c306d939 by Matthew Pickering at 2023-01-06T22:08:53-05:00 ci: Upgrade darwin, windows and freebsd CI to use GHC-9.4.3 Fixes #22599 - - - - - 0db496ff by Matthew Pickering at 2023-01-06T22:08:53-05:00 darwin ci: Explicitly pass desired build triple to configure On the zw3rk machines for some reason the build machine was inferred to be arm64. Setting the build triple appropiately resolve this confusion and we produce x86 binaries. - - - - - 2459c358 by Ben Gamari at 2023-01-06T22:09:29-05:00 rts: MUT_VAR is not a StgMutArrPtrs There was previously a comment claiming that the MUT_VAR closure type had the layout of StgMutArrPtrs. - - - - - 6206cb92 by Simon Peyton Jones at 2023-01-07T12:14:40-05:00 Make FloatIn robust to shadowing This MR fixes #22622. See the new Note [Shadowing and name capture] I did a bit of refactoring in sepBindsByDropPoint too. The bug doesn't manifest in HEAD, but it did show up in 9.4, so we should backport this patch to 9.4 - - - - - a960ca81 by Matthew Pickering at 2023-01-07T12:15:15-05:00 T10955: Set DYLD_LIBRARY_PATH for darwin The correct path to direct the dynamic linker on darwin is DYLD_LIBRARY_PATH rather than LD_LIBRARY_PATH. On recent versions of OSX using LD_LIBRARY_PATH seems to have stopped working. For more reading see: https://stackoverflow.com/questions/3146274/is-it-ok-to-use-dyld-library-path-on-mac-os-x-and-whats-the-dynamic-library-s - - - - - 73484710 by Matthew Pickering at 2023-01-07T12:15:15-05:00 Skip T18623 on darwin (to add to the long list of OSs) On recent versions of OSX, running `ulimit -v` results in ``` ulimit: setrlimit failed: invalid argument ``` Time is too short to work out what random stuff Apple has been doing with ulimit, so just skip the test like we do for other platforms. - - - - - 8c0ea25f by Matthew Pickering at 2023-01-07T12:15:15-05:00 Pass -Wl,-no_fixup_chains to ld64 when appropiate Recent versions of MacOS use a version of ld where `-fixup_chains` is on by default. This is incompatible with our usage of `-undefined dynamic_lookup`. Therefore we explicitly disable `fixup-chains` by passing `-no_fixup_chains` to the linker on darwin. This results in a warning of the form: ld: warning: -undefined dynamic_lookup may not work with chained fixups The manual explains the incompatible nature of these two flags: -undefined treatment Specifies how undefined symbols are to be treated. Options are: error, warning, suppress, or dynamic_lookup. The default is error. Note: dynamic_lookup that depends on lazy binding will not work with chained fixups. A relevant ticket is #22429 Here are also a few other links which are relevant to the issue: Official comment: https://developer.apple.com/forums/thread/719961 More relevant links: https://openradar.appspot.com/radar?id=5536824084660224 https://github.com/python/cpython/issues/97524 Note in release notes: https://developer.apple.com/documentation/xcode-release-notes/xcode-13-releas e-notes - - - - - 365b3045 by Matthew Pickering at 2023-01-09T02:36:20-05:00 Disable split sections on aarch64-deb10 build See #22722 Failure on this job: https://gitlab.haskell.org/ghc/ghc/-/jobs/1287852 ``` Unexpected failures: /builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T10828.run T10828 [exit code non-0] (ext-interp) /builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T13123.run T13123 [exit code non-0] (ext-interp) /builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T20590.run T20590 [exit code non-0] (ext-interp) Appending 232 stats to file: /builds/ghc/ghc/performance-metrics.tsv ``` ``` Compile failed (exit code 1) errors were: data family D_0 a_1 :: * -> * data instance D_0 GHC.Types.Int GHC.Types.Bool :: * where DInt_2 :: D_0 GHC.Types.Int GHC.Types.Bool data E_3 where MkE_4 :: a_5 -> E_3 data Foo_6 a_7 b_8 where MkFoo_9, MkFoo'_10 :: a_11 -> Foo_6 a_11 b_12 newtype Bar_13 :: * -> GHC.Types.Bool -> * where MkBar_14 :: a_15 -> Bar_13 a_15 b_16 data T10828.T (a_0 :: *) where T10828.MkT :: forall (a_1 :: *) . a_1 -> a_1 -> T10828.T a_1 T10828.MkC :: forall (a_2 :: *) (b_3 :: *) . (GHC.Types.~) a_2 GHC.Types.Int => {T10828.foo :: a_2, T10828.bar :: b_3} -> T10828.T GHC.Types.Int T10828.hs:1:1: error: [GHC-87897] Exception when trying to run compile-time code: ghc-iserv terminated (-4) Code: (do TyConI dec <- runQ $ reify (mkName "T") runIO $ putStrLn (pprint dec) >> hFlush stdout d <- runQ $ [d| data T' a :: Type where MkT' :: a -> a -> T' a MkC' :: forall a b. (a ~ Int) => {foo :: a, bar :: b} -> T' Int |] runIO $ putStrLn (pprint d) >> hFlush stdout ....) *** unexpected failure for T10828(ext-interp) =====> 7000 of 9215 [0, 1, 0] =====> 7000 of 9215 [0, 1, 0] =====> 7000 of 9215 [0, 1, 0] =====> 7000 of 9215 [0, 1, 0] Compile failed (exit code 1) errors were: T13123.hs:1:1: error: [GHC-87897] Exception when trying to run compile-time code: ghc-iserv terminated (-4) Code: ([d| data GADT where MkGADT :: forall k proxy (a :: k). proxy a -> GADT |]) *** unexpected failure for T13123(ext-interp) =====> 7100 of 9215 [0, 2, 0] =====> 7100 of 9215 [0, 2, 0] =====> 7200 of 9215 [0, 2, 0] Compile failed (exit code 1) errors were: T20590.hs:1:1: error: [GHC-87897] Exception when trying to run compile-time code: ghc-iserv terminated (-4) Code: ([d| data T where MkT :: forall a. a -> T |]) *** unexpected failure for T20590(ext-interp) ``` Looks fairly worrying to me. - - - - - 965a2735 by Alan Zimmerman at 2023-01-09T02:36:20-05:00 EPA: exact print HsDocTy To match ghc-exactprint https://github.com/alanz/ghc-exactprint/pull/121 - - - - - 5d65773e by John Ericson at 2023-01-09T20:39:27-05:00 Remove RTS hack for configuring See the brand new Note [Undefined symbols in the RTS] for additional details. - - - - - e3fff751 by Sebastian Graf at 2023-01-09T20:40:02-05:00 Handle shadowing in DmdAnal (#22718) Previously, when we had a shadowing situation like ```hs f x = ... -- demand signature <1L><1L> main = ... \f -> f 1 ... ``` we'd happily use the shadowed demand signature at the call site inside the lambda. Of course, that's wrong and solution is simply to remove the demand signature from the `AnalEnv` when we enter the lambda. This patch does so for all binding constructs Core. In #22718 the issue was caused by LetUp not shadowing away the existing demand signature for the let binder in the let body. The resulting absent error is fickle to reproduce; hence no reproduction test case. #17478 would help. Fixes #22718. It appears that TcPlugin_Rewrite regresses by ~40% on Darwin. It is likely that DmdAnal was exploiting ill-scoped analysis results. Metric increase ['bytes allocated'] (test_env=x86_64-darwin-validate): TcPlugin_Rewrite - - - - - d53f6f4d by Oleg Grenrus at 2023-01-09T21:11:02-05:00 Add safe list indexing operator: !? With Joachim's amendments. Implements https://github.com/haskell/core-libraries-committee/issues/110 - - - - - cfaf1ad7 by Nicolas Trangez at 2023-01-09T21:11:03-05:00 rts, tests: limit thread name length to 15 bytes On Linux, `pthread_setname_np` (or rather, the kernel) only allows for thread names up to 16 bytes, including the terminating null byte. This commit adds a note pointing this out in `createOSThread`, and fixes up two instances where a thread name of more than 15 characters long was used (in the RTS, and in a test-case). Fixes: #22366 Fixes: https://gitlab.haskell.org/ghc/ghc/-/issues/22366 See: https://gitlab.haskell.org/ghc/ghc/-/issues/22366#note_460796 - - - - - 64286132 by Matthew Pickering at 2023-01-09T21:11:03-05:00 Store bootstrap_llvm_target and use it to set LlvmTarget in bindists This mirrors some existing logic for the bootstrap_target which influences how TargetPlatform is set. As described on #21970 not storing this led to `LlvmTarget` being set incorrectly and hence the wrong `--target` flag being passed to the C compiler. Towards #21970 - - - - - 4724e8d1 by Matthew Pickering at 2023-01-09T21:11:04-05:00 Check for FP_LD_NO_FIXUP_CHAINS in installation configure script Otherwise, when installing from a bindist the C flag isn't passed to the C compiler. This completes the fix for #22429 - - - - - 2e926b88 by Georgi Lyubenov at 2023-01-09T21:11:07-05:00 Fix outdated link to Happy section on sequences - - - - - 146a1458 by Matthew Pickering at 2023-01-09T21:11:07-05:00 Revert "NCG(x86): Compile add+shift as lea if possible." This reverts commit 20457d775885d6c3df020d204da9a7acfb3c2e5a. See #22666 and #21777 - - - - - 6e6adbe3 by Jade Lovelace at 2023-01-11T00:55:30-05:00 Fix tcPluginRewrite example - - - - - faa57138 by Jade Lovelace at 2023-01-11T00:55:31-05:00 fix missing haddock pipe - - - - - 0470ea7c by Florian Weimer at 2023-01-11T00:56:10-05:00 m4/fp_leading_underscore.m4: Avoid implicit exit function declaration And switch to a new-style function definition. Fixes build issues with compilers that do not accept implicit function declarations. - - - - - b2857df4 by HaskellMouse at 2023-01-11T00:56:52-05:00 Added a new warning about compatibility with RequiredTypeArguments This commit introduces a new warning that indicates code incompatible with future extension: RequiredTypeArguments. Enabling this extension may break some code and the warning will help to make it compatible in advance. - - - - - 5f17e21a by Ben Gamari at 2023-01-11T00:57:27-05:00 testsuite: Drop testheapalloced.c As noted in #22414, this file (which appears to be a benchmark for characterising the one-step allocator's MBlock cache) is currently unreferenced. Remove it. Closes #22414. - - - - - bc125775 by Vladislav Zavialov at 2023-01-11T00:58:03-05:00 Introduce the TypeAbstractions language flag GHC Proposals #448 "Modern scoped type variables" and #425 "Invisible binders in type declarations" introduce a new language extension flag: TypeAbstractions. Part of the functionality guarded by this flag has already been implemented, namely type abstractions in constructor patterns, but it was guarded by a combination of TypeApplications and ScopedTypeVariables instead of a dedicated language extension flag. This patch does the following: * introduces a new language extension flag TypeAbstractions * requires TypeAbstractions for @a-syntax in constructor patterns instead of TypeApplications and ScopedTypeVariables * creates a User's Guide page for TypeAbstractions and moves the "Type Applications in Patterns" section there To avoid a breaking change, the new flag is implied by ScopedTypeVariables and is retroactively added to GHC2021. Metric Decrease: MultiLayerModulesTH_OneShot - - - - - 083f7015 by Krzysztof Gogolewski at 2023-01-11T00:58:38-05:00 Misc cleanup - Remove unused mkWildEvBinder - Use typeTypeOrConstraint - more symmetric and asserts that that the type is Type or Constraint - Fix escape sequences in Python; they raise a deprecation warning with -Wdefault - - - - - aed1974e by Richard Eisenberg at 2023-01-11T08:30:42+00:00 Refactor the treatment of loopy superclass dicts This patch completely re-engineers how we deal with loopy superclass dictionaries in instance declarations. It fixes #20666 and #19690 The highlights are * Recognise that the loopy-superclass business should use precisely the Paterson conditions. This is much much nicer. See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance * With that in mind, define "Paterson-smaller" in Note [Paterson conditions] in GHC.Tc.Validity, and the new data type `PatersonSize` in GHC.Tc.Utils.TcType, along with functions to compute and compare PatsonSizes * Use the new PatersonSize stuff when solving superclass constraints See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance * In GHC.Tc.Solver.Monad.lookupInInerts, add a missing call to prohibitedSuperClassSolve. This was the original cause of #20666. * Treat (TypeError "stuff") as having PatersonSize zero. See Note [Paterson size for type family applications] in GHC.Tc.Utils.TcType. * Treat the head of a Wanted quantified constraint in the same way as the superclass of an instance decl; this is what fixes #19690. See GHC.Tc.Solver.Canonical Note [Solving a Wanted forall-constraint] (Thanks to Matthew Craven for this insight.) This entailed refactoring the GivenSc constructor of CtOrigin a bit, to say whether it comes from an instance decl or quantified constraint. * Some refactoring way in which redundant constraints are reported; we don't want to complain about the extra, apparently-redundant constraints that we must add to an instance decl because of the loopy-superclass thing. I moved some work from GHC.Tc.Errors to GHC.Tc.Solver. * Add a new section to the user manual to describe the loopy superclass issue and what rules it follows. - - - - - 300bcc15 by HaskellMouse at 2023-01-11T13:43:36-05:00 Parse qualified terms in type signatures This commit allows qualified terms in type signatures to pass the parser and to be cathced by renamer with more informative error message. Adds a few tests. Fixes #21605 - - - - - 964284fc by Simon Peyton Jones at 2023-01-11T13:44:12-05:00 Fix void-arg-adding mechanism for worker/wrapper As #22725 shows, in worker/wrapper we must add the void argument /last/, not first. See GHC.Core.Opt.WorkWrap.Utils Note [Worker/wrapper needs to add void arg last]. That led me to to study GHC.Core.Opt.SpecConstr Note [SpecConstr needs to add void args first] which suggests the opposite! And indeed I think it's the other way round for SpecConstr -- or more precisely the void arg must precede the "extra_bndrs". That led me to some refactoring of GHC.Core.Opt.SpecConstr.calcSpecInfo. - - - - - f7ceafc9 by Krzysztof Gogolewski at 2023-01-11T22:36:59-05:00 Add 'docWithStyle' to improve codegen This new combinator docWithStyle :: IsOutput doc => doc -> (PprStyle -> SDoc) -> doc let us remove the need for code to be polymorphic in HDoc when not used in code style. Metric Decrease: ManyConstructors T13035 T1969 - - - - - b3be0d18 by Simon Peyton Jones at 2023-01-11T22:37:35-05:00 Fix finaliseArgBoxities for OPAQUE function We never do worker wrapper for OPAQUE functions, so we must zap the unboxing info during strictness analysis. This patch fixes #22502 - - - - - db11f358 by Ben Gamari at 2023-01-12T07:49:04-05:00 Revert "rts: Drop racy assertion" The logic here was inverted. Reverting the commit to avoid confusion when examining the commit history. This reverts commit b3eacd64fb36724ed6c5d2d24a81211a161abef1. - - - - - 3242139f by Ben Gamari at 2023-01-12T07:49:04-05:00 rts: Drop racy assertion 0e274c39bf836d5bb846f5fa08649c75f85326ac added an assertion in `dirty_MUT_VAR` checking that the MUT_VAR being dirtied was clean. However, this isn't necessarily the case since another thread may have raced us to dirty the object. - - - - - 9ffd5d57 by Ben Gamari at 2023-01-12T07:49:41-05:00 configure: Fix escaping of `$tooldir` In !9547 I introduced `$tooldir` directories into GHC's default link and compilation flags to ensure that our C toolchain finds its own headers and libraries before others on the system. However, the patch was subtly wrong in the escaping of `$tooldir`. Fix this. Fixes #22561. - - - - - 905d0b6e by Sebastian Graf at 2023-01-12T15:51:47-05:00 Fix contification with stable unfoldings (#22428) Many functions now return a `TailUsageDetails` that adorns a `UsageDetails` with a `JoinArity` that reflects the number of join point binders around the body for which the `UsageDetails` was computed. `TailUsageDetails` is now returned by `occAnalLamTail` as well as `occAnalUnfolding` and `occAnalRules`. I adjusted `Note [Join points and unfoldings/rules]` and `Note [Adjusting right-hand sides]` to account for the new machinery. I also wrote a new `Note [Join arity prediction based on joinRhsArity]` and refer to it when we combine `TailUsageDetails` for a recursive RHS. I also renamed * `occAnalLam` to `occAnalLamTail` * `adjustRhsUsage` to `adjustTailUsage` * a few other less important functions and properly documented the that each call of `occAnalLamTail` must pair up with `adjustTailUsage`. I removed `Note [Unfoldings and join points]` because it was redundant with `Note [Occurrences in stable unfoldings]`. While in town, I refactored `mkLoopBreakerNodes` so that it returns a condensed `NodeDetails` called `SimpleNodeDetails`. Fixes #22428. The refactoring seems to have quite beneficial effect on ghc/alloc performance: ``` CoOpt_Read(normal) ghc/alloc 784,778,420 768,091,176 -2.1% GOOD T12150(optasm) ghc/alloc 77,762,270 75,986,720 -2.3% GOOD T12425(optasm) ghc/alloc 85,740,186 84,641,712 -1.3% GOOD T13056(optasm) ghc/alloc 306,104,656 299,811,632 -2.1% GOOD T13253(normal) ghc/alloc 350,233,952 346,004,008 -1.2% T14683(normal) ghc/alloc 2,800,514,792 2,754,651,360 -1.6% T15304(normal) ghc/alloc 1,230,883,318 1,215,978,336 -1.2% T15630(normal) ghc/alloc 153,379,590 151,796,488 -1.0% T16577(normal) ghc/alloc 7,356,797,056 7,244,194,416 -1.5% T17516(normal) ghc/alloc 1,718,941,448 1,692,157,288 -1.6% T19695(normal) ghc/alloc 1,485,794,632 1,458,022,112 -1.9% T21839c(normal) ghc/alloc 437,562,314 431,295,896 -1.4% GOOD T21839r(normal) ghc/alloc 446,927,580 440,615,776 -1.4% GOOD geo. mean -0.6% minimum -2.4% maximum -0.0% ``` Metric Decrease: CoOpt_Read T10421 T12150 T12425 T13056 T18698a T18698b T21839c T21839r T9961 - - - - - a1491c87 by Andreas Klebinger at 2023-01-12T15:52:23-05:00 Only gc sparks locally when we can ensure marking is done. When performing GC without work stealing there was no guarantee that spark pruning was happening after marking of the sparks. This could cause us to GC live sparks under certain circumstances. Fixes #22528. - - - - - 8acfe930 by Cheng Shao at 2023-01-12T15:53:00-05:00 Change MSYSTEM to CLANG64 uniformly - - - - - 73bc162b by M Farkas-Dyck at 2023-01-12T15:53:42-05:00 Make `GHC.Tc.Errors.Reporter` take `NonEmpty ErrorItem` rather than `[ErrorItem]`, which lets us drop some panics. Also use the `BasicMismatch` constructor rather than `mkBasicMismatchMsg`, which lets us drop the "-Wno-incomplete-record-updates" flag. - - - - - 1b812b69 by Oleg Grenrus at 2023-01-12T15:54:21-05:00 Fix #22728: Not all diagnostics in safe check are fatal Also add tests for the issue and -Winferred-safe-imports in general - - - - - c79b2b65 by Matthew Pickering at 2023-01-12T15:54:58-05:00 Don't run hadrian-multi on fast-ci label Fixes #22667 - - - - - 9a3d6add by Bodigrim at 2023-01-13T00:46:36-05:00 Bump submodule bytestring to 0.11.4.0 Metric Decrease: T21839c T21839r - - - - - df33c13c by Ben Gamari at 2023-01-13T00:47:12-05:00 gitlab-ci: Bump Darwin bootstrap toolchain This updates the bootstrap compiler on Darwin from 8.10.7 to 9.2.5, ensuring that we have the fix for #21964. - - - - - 756a66ec by Ben Gamari at 2023-01-13T00:47:12-05:00 gitlab-ci: Pass -w to cabal update Due to cabal#8447, cabal-install 3.8.1.0 requires a compiler to run `cabal update`. - - - - - 1142f858 by Cheng Shao at 2023-01-13T11:04:00+00:00 Bump hsc2hs submodule - - - - - d4686729 by Cheng Shao at 2023-01-13T11:04:00+00:00 Bump process submodule - - - - - 84ae6573 by Cheng Shao at 2023-01-13T11:06:58+00:00 ci: Bump DOCKER_REV - - - - - d53598c5 by Cheng Shao at 2023-01-13T11:06:58+00:00 ci: enable xz parallel compression for x64 jobs - - - - - d31fcbca by Cheng Shao at 2023-01-13T11:06:58+00:00 ci: use in-image emsdk for js jobs - - - - - 93b9bbc1 by Cheng Shao at 2023-01-13T11:47:17+00:00 ci: improve nix-shell for gen_ci.hs and fix some ghc/hlint warnings - Add a ghc environment including prebuilt dependencies to the nix-shell. Get rid of the ad hoc cabal cache and all dependencies are now downloaded from the nixos binary cache. - Make gen_ci.hs a cabal package with HLS integration, to make future hacking of gen_ci.hs easier. - Fix some ghc/hlint warnings after I got HLS to work. - For the lint-ci-config job, do a shallow clone to save a few minutes of unnecessary git checkout time. - - - - - 8acc56c7 by Cheng Shao at 2023-01-13T11:47:17+00:00 ci: source the toolchain env file in wasm jobs - - - - - 87194df0 by Cheng Shao at 2023-01-13T11:47:17+00:00 ci: add wasm ci jobs via gen_ci.hs - There is one regular wasm job run in validate pipelines - Additionally, int-native/unreg wasm jobs run in nightly/release pipelines Also, remove the legacy handwritten wasm ci jobs in .gitlab-ci.yml. - - - - - b6eb9bcc by Matthew Pickering at 2023-01-13T11:52:16+00:00 wasm ci: Remove wasm release jobs This removes the wasm release jobs, as we do not yet intend to distribute these binaries. - - - - - 496607fd by Simon Peyton Jones at 2023-01-13T16:52:07-05:00 Add a missing checkEscapingKind Ticket #22743 pointed out that there is a missing check, for type-inferred bindings, that the inferred type doesn't have an escaping kind. The fix is easy. - - - - - 7a9a1042 by Andreas Klebinger at 2023-01-16T20:48:19-05:00 Separate core inlining logic from `Unfolding` type. This seems like a good idea either way, but is mostly motivated by a patch where this avoids a module loop. - - - - - 33b58f77 by sheaf at 2023-01-16T20:48:57-05:00 Hadrian: generalise &%> to avoid warnings This patch introduces a more general version of &%> that works with general traversable shapes, instead of lists. This allows us to pass along the information that the length of the list of filepaths passed to the function exactly matches the length of the input list of filepath patterns, avoiding pattern match warnings. Fixes #22430 - - - - - 8c7a991c by Andreas Klebinger at 2023-01-16T20:49:34-05:00 Add regression test for #22611. A case were a function used to fail to specialize, but now does. - - - - - 6abea760 by Andreas Klebinger at 2023-01-16T20:50:10-05:00 Mark maximumBy/minimumBy as INLINE. The RHS was too large to inline which often prevented the overhead of the Maybe from being optimized away. By marking it as INLINE we can eliminate the overhead of both the maybe and are able to unpack the accumulator when possible. Fixes #22609 - - - - - 99d151bb by Matthew Pickering at 2023-01-16T20:50:50-05:00 ci: Bump CACHE_REV so that ghc-9.6 branch and HEAD have different caches Having the same CACHE_REV on both branches leads to issues where the darwin toolchain is different on ghc-9.6 and HEAD which leads to long darwin build times. In general we should ensure that each branch has a different CACHE_REV. - - - - - 6a5845fb by Matthew Pickering at 2023-01-16T20:51:25-05:00 ci: Change owner of files in source-tarball job This fixes errors of the form: ``` fatal: detected dubious ownership in repository at '/builds/ghc/ghc' To add an exception for this directory, call: git config --global --add safe.directory /builds/ghc/ghc inferred 9.7.20230113 checking for GHC Git commit id... fatal: detected dubious ownership in repository at '/builds/ghc/ghc' To add an exception for this directory, call: git config --global --add safe.directory /builds/ghc/ghc ``` - - - - - 4afb952c by Matthew Pickering at 2023-01-16T20:51:25-05:00 ci: Don't build aarch64-deb10-llvm job on release pipelines Closes #22721 - - - - - 8039feb9 by Matthew Pickering at 2023-01-16T20:51:25-05:00 ci: Change owner of files in test-bootstrap job - - - - - 0b358d0c by Matthew Pickering at 2023-01-16T20:51:25-05:00 rel_eng: Add release engineering scripts into ghc tree It is better to keep these scripts in the tree as they depend on the CI configuration and so on. By keeping them in tree we can keep them up-to-date as the CI config changes and also makes it easier to backport changes to the release script between release branches in future. The final motivation is that it makes generating GHCUp metadata possible. - - - - - 28cb2ed0 by Matthew Pickering at 2023-01-16T20:51:25-05:00 ci: Don't use complicated image or clone in not-interruptible job This job exists only for the meta-reason of not allowing nightly pipelines to be cancelled. It was taking two minutes to run as in order to run "true" we would also clone the whole GHC repo. - - - - - eeea59bb by Matthew Pickering at 2023-01-16T20:51:26-05:00 Add scripts to generate ghcup metadata on nightly and release pipelines 1. A python script in .gitlab/rel_eng/mk-ghcup-metadata which generates suitable metadata for consumption by GHCUp for the relevant pipelines. - The script generates the metadata just as the ghcup maintainers want, without taking into account platform/library combinations. It is updated manually when the mapping changes. - The script downloads the bindists which ghcup wants to distribute, calculates the hash and generates the yaml in the correct structure. - The script is documented in the .gitlab/rel_eng/mk-ghcup-metadata/README.mk file 1a. The script requires us to understand the mapping from platform -> job. To choose the preferred bindist for each platform the .gitlab/gen_ci.hs script is modified to allow outputting a metadata file which answers the question about which job produces the bindist which we want to distribute to users for a specific platform. 2. Pipelines to run on nightly and release jobs to generate metadata - ghcup-metadata-nightly: Generates metadata which points directly to artifacts in the nightly job. - ghcup-metadata-release: Generates metadata suitable for inclusion directly in ghcup by pointing to the downloads folder where the bindist will be uploaded to. 2a. Trigger jobs which test the generated metadata in the downstream `ghccup-ci` repo. See that repo for documentation about what is tested and how but essentially we test in a variety of clean images that ghcup can download and install the bindists we say exist in our metadata. - - - - - 97bd4d8c by Bodigrim at 2023-01-16T20:52:04-05:00 Bump submodule parsec to 3.1.16.1 - - - - - 97ac8230 by Alan Zimmerman at 2023-01-16T20:52:39-05:00 EPA: Add annotation for 'type' in DataDecl Closes #22765 - - - - - dbbab95d by Ben Gamari at 2023-01-17T06:36:06-05:00 compiler: Small optimisation of assertM In #22739 @AndreasK noticed that assertM performed the action to compute the asserted predicate regardless of whether DEBUG is enabled. This is inconsistent with the other assertion operations and general convention. Fix this. Closes #22739. - - - - - fc02f3bb by Viktor Dukhovni at 2023-01-17T06:36:47-05:00 Avoid unnecessary printf warnings in EventLog.c Fixes #22778 - - - - - 003b6d44 by Simon Peyton Jones at 2023-01-17T16:33:05-05:00 Document the semantics of pattern bindings a bit better This MR is in response to the discussion on #22719 - - - - - f4d50baf by Vladislav Zavialov at 2023-01-17T16:33:41-05:00 Hadrian: fix warnings (#22783) This change fixes the following warnings when building Hadrian: src/Hadrian/Expression.hs:38:10: warning: [-Wredundant-constraints] src/Hadrian/Expression.hs:84:13: warning: [-Wtype-equality-requires-operators] src/Hadrian/Expression.hs:84:21: warning: [-Wtype-equality-requires-operators] src/Hadrian/Haskell/Cabal/Parse.hs:67:1: warning: [-Wunused-imports] - - - - - 06036d93 by Sylvain Henry at 2023-01-18T01:55:10-05:00 testsuite: req_smp --> req_target_smp, req_ghc_smp See #22630 and !9552 This commit: - splits req_smp into req_target_smp and req_ghc_smp - changes the testsuite driver to calculate req_ghc_smp - changes a handful of tests to use req_target_smp instead of req_smp - changes a handful of tests to use req_host_smp when needed The problem: - the problem this solves is the ambiguity surrounding req_smp - on master req_smp was used to express the constraint that the program being compiled supports smp _and_ that the host RTS (i.e., the RTS used to compile the program) supported smp. Normally that is fine, but in cross compilation this is not always the case as was discovered in #22630. The solution: - Differentiate the two constraints: - use req_target_smp to say the RTS the compiled program is linked with (and the platform) supports smp - use req_host_smp to say the RTS the host is linked with supports smp WIP: fix req_smp (target vs ghc) add flag to separate bootstrapper split req_smp -> req_target_smp and req_ghc_smp update tests smp flags cleanup and add some docstrings only set ghc_with_smp to bootstrapper on S1 or CC Only set ghc_with_smp to bootstrapperWithSMP of when testing stage 1 and cross compiling test the RTS in config/ghc not hadrian re-add ghc_with_smp fix and align req names fix T11760 to use req_host_smp test the rts directly, avoid python 3.5 limitation test the compiler in a try block align out of tree and in tree withSMP flags mark failing tests as host req smp testsuite: req_host_smp --> req_ghc_smp Fix ghc vs host, fix ghc_with_smp leftover - - - - - ee9b78aa by Krzysztof Gogolewski at 2023-01-18T01:55:45-05:00 Use -Wdefault when running Python testdriver (#22727) - - - - - e9c0537c by Vladislav Zavialov at 2023-01-18T01:56:22-05:00 Enable -Wstar-is-type by default (#22759) Following the plan in GHC Proposal #143 "Remove the * kind syntax", which states: In the next release (or 3 years in), enable -fwarn-star-is-type by default. The "next release" happens to be 9.6.1 I also moved the T21583 test case from should_fail to should_compile, because the only reason it was failing was -Werror=compat in our test suite configuration. - - - - - 4efee43d by Ryan Scott at 2023-01-18T01:56:59-05:00 Add missing parenthesizeHsType in cvtSigTypeKind We need to ensure that the output of `cvtSigTypeKind` is parenthesized (at precedence `sigPrec`) so that any type signatures with an outermost, explicit kind signature can parse correctly. Fixes #22784. - - - - - f891a442 by Ben Gamari at 2023-01-18T07:28:00-05:00 Bump ghc-tarballs to fix #22497 It turns out that gmp 6.2.1 uses the platform-reserved `x18` register on AArch64/Darwin. This was fixed in upstream changeset 18164:5f32dbc41afc, which was merged in 2020. Here I backport this patch although I do hope that a new release is forthcoming soon. Bumps gmp-tarballs submodule. Fixes #22497. - - - - - b13c6ea5 by Ben Gamari at 2023-01-18T07:28:00-05:00 Bump gmp-tarballs submodule This backports the upstream fix for CVE-2021-43618, fixing #22789. - - - - - c45a5fff by Cheng Shao at 2023-01-18T07:28:37-05:00 Fix typo in recent darwin tests fix Corrects a typo in !9647. Otherwise T18623 will still fail on darwin and stall other people's work. - - - - - b4c14c4b by Luite Stegeman at 2023-01-18T14:21:42-05:00 Add PrimCallConv support to GHCi This adds support for calling Cmm code from bytecode using the native calling convention, allowing modules that use `foreign import prim` to be loaded and debugged in GHCi. This patch introduces a new `PRIMCALL` bytecode instruction and a helper stack frame `stg_primcall`. The code is based on the existing functionality for dealing with unboxed tuples in bytecode, which has been generalised to handle arbitrary calls. Fixes #22051 - - - - - d0a63ef8 by Adam Gundry at 2023-01-18T14:22:26-05:00 Refactor warning flag parsing to add missing flags This adds `-Werror=<group>` and `-fwarn-<group>` flags for warning groups as well as individual warnings. Previously these were defined on an ad hoc basis so for example we had `-Werror=compat` but not `-Werror=unused-binds`, whereas we had `-fwarn-unused-binds` but not `-fwarn-compat`. Fixes #22182. - - - - - 7ed1b8ef by Adam Gundry at 2023-01-18T14:22:26-05:00 Minor corrections to comments - - - - - 5389681e by Adam Gundry at 2023-01-18T14:22:26-05:00 Revise warnings documentation in user's guide - - - - - ab0d5cda by Adam Gundry at 2023-01-18T14:22:26-05:00 Move documentation of deferred type error flags out of warnings section - - - - - eb5a6b91 by John Ericson at 2023-01-18T22:24:10-05:00 Give the RTS it's own configure script Currently it doesn't do much anything, we are just trying to introduce it without breaking the build. Later, we will move functionality from the top-level configure script over to it. We need to bump Cabal for https://github.com/haskell/cabal/pull/8649; to facilitate and existing hack of skipping some configure checks for the RTS we now need to skip just *part* not *all* of the "post configure" hook, as running the configure script (which we definitely want to do) is also implemented as part of the "post configure" hook. But doing this requires exposing functionality that wasn't exposed before. - - - - - 32ab07bf by Bodigrim at 2023-01-18T22:24:51-05:00 ghc package does not have to depend on terminfo - - - - - 981ff7c4 by Bodigrim at 2023-01-18T22:24:51-05:00 ghc-pkg does not have to depend on terminfo - - - - - f058e367 by Ben Gamari at 2023-01-18T22:25:27-05:00 nativeGen/X86: MFENCE is unnecessary for release semantics In #22764 a user noticed that a program implementing a simple atomic counter via an STRef regressed significantly due to the introduction of necessary atomic operations in the MutVar# primops (#22468). This regression was caused by a bug in the NCG, which emitted an unnecessary MFENCE instruction for a release-ordered atomic write. MFENCE is rather only needed to achieve sequentially consistent ordering. Fixes #22764. - - - - - 154889db by Ryan Scott at 2023-01-18T22:26:03-05:00 Add regression test for #22151 Issue #22151 was coincidentally fixed in commit aed1974e92366ab8e117734f308505684f70cddf (`Refactor the treatment of loopy superclass dicts`). This adds a regression test to ensure that the issue remains fixed. Fixes #22151. - - - - - 14b5982a by Andrei Borzenkov at 2023-01-18T22:26:43-05:00 Fix printing of promoted MkSolo datacon (#22785) Problem: In 2463df2f, the Solo data constructor was renamed to MkSolo, and Solo was turned into a pattern synonym for backwards compatibility. Since pattern synonyms can not be promoted, the old code that pretty-printed promoted single-element tuples started producing ill-typed code: t :: Proxy ('Solo Int) This fails with "Pattern synonym ‘Solo’ used as a type" The solution is to track the distinction between type constructors and data constructors more carefully when printing single-element tuples. - - - - - 1fe806d3 by Cheng Shao at 2023-01-23T04:48:47-05:00 hadrian: add hi_core flavour transformer The hi_core flavour transformer enables -fwrite-if-simplified-core for stage1 libraries, which emit core into interface files to make it possible to restart code generation. Building boot libs with it makes it easier to use GHC API to prototype experimental backends that needs core/stg at link time. - - - - - 317cad26 by Cheng Shao at 2023-01-23T04:48:47-05:00 hadrian: add missing docs for recently added flavour transformers - - - - - 658f4446 by Ben Gamari at 2023-01-23T04:49:23-05:00 gitlab-ci: Add Rocky8 jobs Addresses #22268. - - - - - a83ec778 by Vladislav Zavialov at 2023-01-23T04:49:58-05:00 Set "since: 9.8" for TypeAbstractions and -Wterm-variable-capture These flags did not make it into the 9.6 release series, so the "since" annotations must be corrected. - - - - - fec7c2ea by Alan Zimmerman at 2023-01-23T04:50:33-05:00 EPA: Add SourceText to HsOverLabel To be able to capture string literals with possible escape codes as labels. Close #22771 - - - - - 3efd1e99 by Ben Gamari at 2023-01-23T04:51:08-05:00 template-haskell: Bump version to 2.20.0.0 Updates `text` and `exceptions` submodules for bounds bumps. Addresses #22767. - - - - - 0900b584 by Cheng Shao at 2023-01-23T04:51:45-05:00 hadrian: disable alloca for in-tree GMP on wasm32 When building in-tree GMP for wasm32, disable its alloca usage, since it may potentially cause stack overflow (e.g. #22602). - - - - - db0f1bfd by Cheng Shao at 2023-01-23T04:52:21-05:00 Bump process submodule Includes a critical fix for wasm32, see https://github.com/haskell/process/pull/272 for details. Also changes the existing cross test to include process stuff and avoid future regression here. - - - - - 9222b167 by Matthew Pickering at 2023-01-23T04:52:57-05:00 ghcup metadata: Fix subdir for windows bindist - - - - - 9a9bec57 by Matthew Pickering at 2023-01-23T04:52:57-05:00 ghcup metadata: Remove viPostRemove field from generated metadata This has been removed from the downstream metadata. - - - - - 82884ce0 by Simon Peyton Jones at 2023-01-23T04:53:32-05:00 Fix #22742 runtimeRepLevity_maybe was panicing unnecessarily; and the error printing code made use of the case when it should return Nothing rather than panicing. For some bizarre reason perf/compiler/T21839r shows a 10% bump in runtime peak-megagbytes-used, on a single architecture (alpine). See !9753 for commentary, but I'm going to accept it. Metric Increase: T21839r - - - - - 2c6deb18 by Bryan Richter at 2023-01-23T14:12:22+02:00 codeowners: Add Ben, Matt, and Bryan to CI - - - - - eee3bf05 by Matthew Craven at 2023-01-23T21:46:41-05:00 Do not collect compile-time metrics for T21839r ...the testsuite doesn't handle this properly since it also collects run-time metrics. Compile-time metrics for this test are already tracked via T21839c. Metric Decrease: T21839r - - - - - 1d1dd3fb by Matthew Pickering at 2023-01-24T05:37:52-05:00 Fix recompilation checking for multiple home units The key part of this change is to store a UnitId in the `UsageHomeModule` and `UsageHomeModuleInterface`. * Fine-grained dependency tracking is used if the dependency comes from any home unit. * We actually look up the right module when checking whether we need to recompile in the `UsageHomeModuleInterface` case. These scenarios are both checked by the new tests ( multipleHomeUnits_recomp and multipleHomeUnits_recomp_th ) Fixes #22675 - - - - - 7bfb30f9 by Matthew Pickering at 2023-01-24T05:37:52-05:00 Augment target filepath by working directory when checking if module satisfies target This fixes a spurious warning in -Wmissing-home-modules. This is a simple oversight where when looking for the target in the first place we augment the search by the -working-directory flag but then fail to do so when checking this warning. Fixes #22676 - - - - - 69500dd4 by Matthew Pickering at 2023-01-24T05:37:52-05:00 Use NodeKey rather than ModuleName in pruneCache The `pruneCache` function assumes that the list of `CachedInfo` all have unique `ModuleName`, this is not true: * In normal compilation, the same module name can appear for a file and it's boot file. * In multiple home unit compilation the same ModuleName can appear in different units The fix is to use a `NodeKey` as the actual key for the interfaces which includes `ModuleName`, `IsBoot` and `UnitId`. Fixes #22677 - - - - - 336b2b1c by Matthew Pickering at 2023-01-24T05:37:52-05:00 Recompilation checking: Don't try to find artefacts for Interactive & hs-boot combo In interactive mode we don't produce any linkables for hs-boot files. So we also need to not going looking for them when we check to see if we have all the right objects needed for recompilation. Ticket #22669 - - - - - 6469fea7 by Matthew Pickering at 2023-01-24T05:37:52-05:00 Don't write o-boot files in Interactive mode We should not be producing object files when in interactive mode but we still produced the dummy o-boot files. These never made it into a `Linkable` but then confused the recompilation checker. Fixes #22669 - - - - - 06cc0a95 by Matthew Pickering at 2023-01-24T05:37:52-05:00 Improve driver diagnostic messages by including UnitId in message Currently the driver diagnostics don't give any indication about which unit they correspond to. For example `-Wmissing-home-modules` can fire multiple times for each different home unit and gives no indication about which unit it's actually reporting about. Perhaps a longer term fix is to generalise the providence information away from a SrcSpan so that these kind of whole project errors can be reported with an accurate provenance. For now we can just include the `UnitId` in the error message. Fixes #22678 - - - - - 4fe9eaff by Matthew Pickering at 2023-01-24T05:37:52-05:00 Key ModSummary cache by UnitId as well as FilePath Multiple units can refer to the same files without any problem. Just another assumption which needs to be updated when we may have multiple home units. However, there is the invariant that within each unit each file only maps to one module, so as long as we also key the cache by UnitId then we are all good. This led to some confusing behaviour in GHCi when reloading, multipleHomeUnits_shared distils the essence of what can go wrong. Fixes #22679 - - - - - ada29f5c by Matthew Pickering at 2023-01-24T05:37:52-05:00 Finder: Look in current unit before looking in any home package dependencies In order to preserve existing behaviour it's important to look within the current component before consideirng a module might come from an external component. This already happened by accident in `downsweep`, (because roots are used to repopulated the cache) but in the `Finder` the logic was the wrong way around. Fixes #22680 ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp -------------------------p - - - - - be701cc6 by Matthew Pickering at 2023-01-24T05:37:52-05:00 Debug: Print full NodeKey when pretty printing ModuleGraphNode This is helpful when debugging multiple component issues. - - - - - 34d2d463 by Krzysztof Gogolewski at 2023-01-24T05:38:32-05:00 Fix Lint check for duplicate external names Lint was checking for duplicate external names by calling removeDups, which needs a comparison function that is passed to Data.List.sortBy. But the comparison was not a valid ordering - it returned LT if one of the names was not external. For example, the previous implementation won't find a duplicate in [M.x, y, M.x]. Instead, we filter out non-external names before looking for duplicates. - - - - - 1c050ed2 by Matthew Pickering at 2023-01-24T05:39:08-05:00 Add test for T22671 This was fixed by b13c6ea5 Closes #22671 - - - - - 05e6a2d9 by Tom Ellis at 2023-01-24T12:10:52-05:00 Clarify where `f` is defined - - - - - d151546e by Cheng Shao at 2023-01-24T12:11:29-05:00 CmmToC: fix CmmRegOff for 64-bit register on a 32-bit target We used to print the offset value to a platform word sized integer. This is incorrect when the offset is negative (e.g. output of cmm constant folding) and the register is 64-bit but on a 32-bit target, and may lead to incorrect runtime result (e.g. #22607). The fix is simple: just treat it as a proper MO_Add, with the correct width info inferred from the register itself. Metric Increase: T12707 T13379 T4801 T5321FD T5321Fun - - - - - e5383a29 by Wander Hillen at 2023-01-24T20:02:26-05:00 Allow waiting for timerfd to be interrupted during rts shutdown - - - - - 1957eda1 by Ryan Scott at 2023-01-24T20:03:01-05:00 Restore Compose's Read/Show behavior to match Read1/Show1 instances Fixes #22816. - - - - - 30972827 by Matthew Pickering at 2023-01-25T03:54:14-05:00 docs: Update INSTALL.md Removes references to make. Fixes #22480 - - - - - bc038c3b by Cheng Shao at 2023-01-25T03:54:50-05:00 compiler: fix handling of MO_F_Neg in wasm NCG In the wasm NCG, we used to compile MO_F_Neg to 0.0-x. It was an oversight, there actually exists f32.neg/f64.neg opcodes in the wasm spec and those should be used instead! The old behavior almost works, expect when GHC compiles the -0.0 literal, which will incorrectly become 0.0. - - - - - e987e345 by Sylvain Henry at 2023-01-25T14:47:41-05:00 Hadrian: correctly detect AR at-file support Stage0's ar may not support at-files. Take it into account. Found while cross-compiling from Darwin to Windows. - - - - - 48131ee2 by Sylvain Henry at 2023-01-25T14:47:41-05:00 Hadrian: fix Windows cross-compilation Decision to build either unix or Win32 package must be stage specific for cross-compilation to be supported. - - - - - 288fa017 by Sylvain Henry at 2023-01-25T14:47:41-05:00 Fix RTS build on Windows This change fixes a cross-compilation issue from ArchLinux to Windows because these symbols weren't found. - - - - - 2fdf22ae by Sylvain Henry at 2023-01-25T14:47:41-05:00 configure: support "windows" as an OS - - - - - 13a0566b by Simon Peyton Jones at 2023-01-25T14:48:16-05:00 Fix in-scope set in specImports Nothing deep here; I had failed to bring some floated dictionary binders into scope. Exposed by -fspecialise-aggressively Fixes #22715. - - - - - b7efdb24 by Matthew Pickering at 2023-01-25T14:48:51-05:00 ci: Disable HLint job due to excessive runtime The HLint jobs takes much longer to run (20 minutes) after "Give the RTS it's own configure script" eb5a6b91 Now the CI job will build the stage0 compiler before it generates the necessary RTS headers. We either need to: * Fix the linting rules so they take much less time * Revert the commit * Remove the linting of base from the hlint job * Remove the hlint job This is highest priority as it is affecting all CI pipelines. For now I am just disabling the job because there are many more pressing matters at hand. Ticket #22830 - - - - - 1bd32a35 by Sylvain Henry at 2023-01-26T12:34:21-05:00 Factorize hptModulesBelow Create and use moduleGraphModulesBelow in GHC.Unit.Module.Graph that doesn't need anything from the driver to be used. - - - - - 1262d3f8 by Matthew Pickering at 2023-01-26T12:34:56-05:00 Store dehydrated data structures in CgModBreaks This fixes a tricky leak in GHCi where we were retaining old copies of HscEnvs when reloading. If not all modules were recompiled then these hydrated fields in break points would retain a reference to the old HscEnv which could double memory usage. Fixes #22530 - - - - - e27eb80c by Matthew Pickering at 2023-01-26T12:34:56-05:00 Force more in NFData Name instance Doesn't force the lazy `OccName` field (#19619) which is already known as a really bad source of leaks. When we slam the hammer storing Names on disk (in interface files or the like), all this should be forced as otherwise a `Name` can easily retain an `Id` and hence the entire world. Fixes #22833 - - - - - 3d004d5a by Matthew Pickering at 2023-01-26T12:34:56-05:00 Force OccName in tidyTopName This occname has just been derived from an `Id`, so need to force it promptly so we can release the Id back to the world. Another symptom of the bug caused by #19619 - - - - - f2a0fea0 by Matthew Pickering at 2023-01-26T12:34:56-05:00 Strict fields in ModNodeKey (otherwise retains HomeModInfo) Towards #22530 - - - - - 5640cb1d by Sylvain Henry at 2023-01-26T12:35:36-05:00 Hadrian: fix doc generation Was missing dependencies on files generated by templates (e.g. ghc.cabal) - - - - - 3e827c3f by Richard Eisenberg at 2023-01-26T20:06:53-05:00 Do newtype unwrapping in the canonicaliser and rewriter See Note [Unwrap newtypes first], which has the details. Close #22519. - - - - - b3ef5c89 by doyougnu at 2023-01-26T20:07:48-05:00 tryFillBuffer: strictify more speculative bangs - - - - - d0d7ba0f by Vladislav Zavialov at 2023-01-26T20:08:25-05:00 base: NoImplicitPrelude in Data.Void and Data.Kind This change removes an unnecessary dependency on Prelude from two modules in the base package. - - - - - fa1db923 by Matthew Pickering at 2023-01-26T20:09:00-05:00 ci: Add ubuntu18_04 nightly and release jobs This adds release jobs for ubuntu18_04 which uses glibc 2.27 which is older than the 2.28 which is used by Rocky8 bindists. Ticket #22268 - - - - - 807310a1 by Matthew Pickering at 2023-01-26T20:09:00-05:00 rel-eng: Add missing rocky8 bindist We intend to release rocky8 bindist so the fetching script needs to know about them. - - - - - c7116b10 by Ben Gamari at 2023-01-26T20:09:35-05:00 base: Make changelog proposal references more consistent Addresses #22773. - - - - - 6932cfc7 by Sylvain Henry at 2023-01-26T20:10:27-05:00 Fix spurious change from !9568 - - - - - e480fbc2 by Ben Gamari at 2023-01-27T05:01:24-05:00 rts: Use C11-compliant static assertion syntax Previously we used `static_assert` which is only available in C23. By contrast, C11 only provides `_Static_assert`. Fixes #22777 - - - - - 2648c09c by Andrei Borzenkov at 2023-01-27T05:02:07-05:00 Replace errors from badOrigBinding with new one (#22839) Problem: in 02279a9c the type-level [] syntax was changed from a built-in name to an alias for the GHC.Types.List constructor. badOrigBinding assumes that if a name is not built-in then it must have come from TH quotation, but this is not necessarily the case with []. The outdated assumption in badOrigBinding leads to incorrect error messages. This code: data [] Fails with "Cannot redefine a Name retrieved by a Template Haskell quote: []" Unfortunately, there is not enough information in RdrName to directly determine if the name was constructed via TH or by the parser, so this patch changes the error message instead. It unifies TcRnIllegalBindingOfBuiltIn and TcRnNameByTemplateHaskellQuote into a new error TcRnBindingOfExistingName and changes its wording to avoid guessing the origin of the name. - - - - - 545bf8cf by Matthew Pickering at 2023-01-27T14:58:53+00:00 Revert "base: NoImplicitPrelude in Data.Void and Data.Kind" Fixes CI errors of the form. ``` ===> Command failed with error code: 1 ghc: panic! (the 'impossible' happened) GHC version 9.7.20230127: lookupGlobal Failed to load interface for ‘GHC.Num.BigNat’ There are files missing in the ‘ghc-bignum’ package, try running 'ghc-pkg check'. Use -v (or `:set -v` in ghci) to see a list of the files searched for. Call stack: CallStack (from HasCallStack): callStackDoc, called at compiler/GHC/Utils/Panic.hs:189:37 in ghc:GHC.Utils.Panic pprPanic, called at compiler/GHC/Tc/Utils/Env.hs:154:32 in ghc:GHC.Tc.Utils.Env CallStack (from HasCallStack): panic, called at compiler/GHC/Utils/Error.hs:454:29 in ghc:GHC.Utils.Error Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug ``` This reverts commit d0d7ba0fb053ebe7f919a5932066fbc776301ccd. The module now lacks a dependency on GHC.Num.BigNat which it implicitly depends on. It is causing all CI jobs to fail so we revert without haste whilst the patch can be fixed. Fixes #22848 - - - - - 638277ba by Simon Peyton Jones at 2023-01-27T23:54:55-05:00 Detect family instance orphans correctly We were treating a type-family instance as a non-orphan if there was a type constructor on its /right-hand side/ that was local. Boo! Utterly wrong. With this patch, we correctly check the /left-hand side/ instead! Fixes #22717 - - - - - 46a53bb2 by Simon Peyton Jones at 2023-01-27T23:54:55-05:00 Report family instance orphans correctly This fixes the fact that we were not reporting orphan family instances at all. The fix here is easy, but touches a bit of code. I refactored the code to be much more similar to the way that class instances are done: - Add a fi_orphan field to FamInst, like the is_orphan field in ClsInst - Make newFamInst initialise this field, just like newClsInst - And make newFamInst report a warning for an orphan, just like newClsInst - I moved newFamInst from GHC.Tc.Instance.Family to GHC.Tc.Utils.Instantiate, just like newClsInst. - I added mkLocalFamInst to FamInstEnv, just like mkLocalClsInst in InstEnv - TcRnOrphanInstance and SuggestFixOrphanInstance are now parametrised over class instances vs type/data family instances. Fixes #19773 - - - - - faa300fb by Simon Peyton Jones at 2023-01-27T23:54:55-05:00 Avoid orphans in STG This patch removes some orphan instances in the STG namespace by introducing the GHC.Stg.Lift.Types module, which allows various type family instances to be moved to GHC.Stg.Syntax, avoiding orphan instances. - - - - - 0f25a13b by Simon Peyton Jones at 2023-01-27T23:54:55-05:00 Avoid orphans in the parser This moves Anno instances for PatBuilder from GHC.Parser.PostProcess to GHC.Parser.Types to avoid orphans. - - - - - 15750d33 by Simon Peyton Jones at 2023-01-27T23:54:55-05:00 Accept an orphan declaration (sadly) This accepts the orphan type family instance type instance DsForeignHook = ... in GHC.HsToCore.Types. See Note [The Decoupling Abstract Data Hack] in GHC.Driver.Hooks - - - - - c9967d13 by Zubin Duggal at 2023-01-27T23:55:31-05:00 bindist configure: Fail if find not found (#22691) - - - - - ad8cfed4 by John Ericson at 2023-01-27T23:56:06-05:00 Put hadrian bootstrap plans through `jq` This makes it possible to review changes with conventional diffing tools. - - - - - d0ddc01b by Ben Gamari at 2023-01-27T23:56:42-05:00 testsuite: Introduce threaded2_sanity way Incredibly, we previously did not have a single way which would test the threaded RTS with multiple capabilities and the sanity-checker enabled. - - - - - 38ad8351 by Ben Gamari at 2023-01-27T23:56:42-05:00 rts: Relax Messages assertion `doneWithMsgThrowTo` was previously too strict in asserting that the `Message` is locked. Specifically, it failed to consider that the `Message` may not be locked if we are deleting all threads during RTS shutdown. - - - - - a9fe81af by Ben Gamari at 2023-01-27T23:56:42-05:00 testsuite: Fix race in UnliftedTVar2 Previously UnliftedTVar2 would fail when run with multiple capabilities (and possibly even with one capability) as it would assume that `killThread#` would immediately kill the "increment" thread. Also, refactor the the executable to now succeed with no output and fails with an exit code. - - - - - 8519af60 by Ben Gamari at 2023-01-27T23:56:42-05:00 testsuite: Make listThreads more robust Previously it was sensitive to the labels of threads which it did not create (e.g. the IO manager event loop threads). Fix this. - - - - - 55a81995 by Ben Gamari at 2023-01-27T23:56:43-05:00 rts: Fix non-atomic mutation of enabled_capabilities - - - - - b5c75f1d by Ben Gamari at 2023-01-27T23:56:43-05:00 rts: Fix C++ compilation issues Make the RTS compilable with a C++ compiler by inserting necessary casts. - - - - - c261b62f by Ben Gamari at 2023-01-27T23:56:43-05:00 rts: Fix typo "tracingAddCapabilities" was mis-named - - - - - 77fdbd3f by Ben Gamari at 2023-01-27T23:56:43-05:00 rts: Drop long-dead fallback definitions for INFINITY & NAN These are no longer necessary since we now compile as C99. - - - - - 56c1bd98 by Ben Gamari at 2023-01-28T02:57:59-05:00 Revert "CApiFFI: add ConstPtr for encoding const-qualified pointer return types (#22043)" This reverts commit 99aca26b652603bc62953157a48e419f737d352d. - - - - - b3a3534b by nineonine at 2023-01-28T02:57:59-05:00 CApiFFI: add ConstPtr for encoding const-qualified pointer return types Previously, when using `capi` calling convention in foreign declarations, code generator failed to handle const-cualified pointer return types. This resulted in CC toolchain throwing `-Wincompatible-pointer-types-discards-qualifiers` warning. `Foreign.C.Types.ConstPtr` newtype was introduced to handle these cases - special treatment was put in place to generate appropritetly qualified C wrapper that no longer triggers the above mentioned warning. Fixes #22043. - - - - - 082b7d43 by Oleg Grenrus at 2023-01-28T02:58:38-05:00 Add Foldable1 Solo instance - - - - - 50b1e2e8 by Andrei Borzenkov at 2023-01-28T02:59:18-05:00 Convert diagnostics in GHC.Rename.Bind to proper TcRnMessage (#20115) I removed all occurrences of TcRnUnknownMessage in GHC.Rename.Bind module. Instead, these TcRnMessage messages were introduced: TcRnMultipleFixityDecls TcRnIllegalPatternSynonymDecl TcRnIllegalClassBiding TcRnOrphanCompletePragma TcRnEmptyCase TcRnNonStdGuards TcRnDuplicateSigDecl TcRnMisplacedSigDecl TcRnUnexpectedDefaultSig TcRnBindInBootFile TcRnDuplicateMinimalSig - - - - - 3330b819 by Matthew Pickering at 2023-01-28T02:59:54-05:00 hadrian: Fix library-dirs, dynamic-library-dirs and static-library-dirs in inplace .conf files Previously we were just throwing away the contents of the library-dirs fields but really we have to do the same thing as for include-dirs, relativise the paths into the current working directory and maintain any extra libraries the user has specified. Now the relevant section of the rts.conf file looks like: ``` library-dirs: ${pkgroot}/../rts/build ${pkgroot}/../../..//_build/stage1/rts/build /nix/store/av4c0fib4rkmb6sa1074z0rb1ciria5b-gperftools-2.10/lib /nix/store/2infxahfp9lj084xn3q9ib5ajks8447i-libffi-3.4.4/lib library-dirs-static: ${pkgroot}/../rts/build ${pkgroot}/../../..//_build/stage1/rts/build /nix/store/av4c0fib4rkmb6sa1074z0rb1ciria5b-gperftools-2.10/lib /nix/store/2infxahfp9lj084xn3q9ib5ajks8447i-libffi-3.4.4/lib dynamic-library-dirs: ${pkgroot}/../rts/build ${pkgroot}/../../..//_build/stage1/rts/build /nix/store/av4c0fib4rkmb6sa1074z0rb1ciria5b-gperftools-2.10/lib /nix/store/2infxahfp9lj084xn3q9ib5ajks8447i-libffi-3.4.4/lib ``` Fixes #22209 - - - - - c9ad8852 by Bodigrim at 2023-01-28T03:00:33-05:00 Document differences between Data.{Monoid,Semigroup}.{First,Last} - - - - - 7e11c6dc by Cheng Shao at 2023-01-28T03:01:09-05:00 compiler: fix subword literal narrowing logic in the wasm NCG This patch fixes the W8/W16 literal narrowing logic in the wasm NCG, which used to lower it to something like i32.const -1, without properly zeroing-out the unused higher bits. Fixes #22608. - - - - - 6ea2aa02 by Cheng Shao at 2023-01-28T03:01:46-05:00 compiler: fix lowering of CmmBlock in the wasm NCG The CmmBlock datacon was not handled in lower_CmmLit, since I thought it would have been eliminated after proc-point splitting. Turns out it still occurs in very rare occasions, and this patch is needed to fix T9329 for wasm. - - - - - 2b62739d by Bodigrim at 2023-01-28T17:16:11-05:00 Assorted changes to avoid Data.List.{head,tail} - - - - - 78c07219 by Cheng Shao at 2023-01-28T17:16:48-05:00 compiler: properly handle ForeignHints in the wasm NCG Properly handle ForeignHints of ccall arguments/return value, insert sign extends and truncations when handling signed subwords. Fixes #22852. - - - - - 8bed166b by Ben Gamari at 2023-01-30T05:06:26-05:00 nativeGen: Disable asm-shortcutting on Darwin Asm-shortcutting may produce relative references to symbols defined in other compilation units. This is not something that MachO relocations support (see #21972). For this reason we disable the optimisation on Darwin. We do so without a warning since this flag is enabled by `-O2`. Another way to address this issue would be to rather implement a PLT-relocatable jump-table strategy. However, this would only benefit Darwin and does not seem worth the effort. Closes #21972. - - - - - da468391 by Cheng Shao at 2023-01-30T05:07:03-05:00 compiler: fix data section alignment in the wasm NCG Previously we tried to lower the alignment requirement as far as possible, based on the section kind inferred from the CLabel. For info tables, .p2align 1 was applied given the GC should only need the lowest bit to tag forwarding pointers. But this would lead to unaligned loads/stores, which has a performance penalty even if the wasm spec permits it. Furthermore, the test suite has shown memory corruption in a few cases when compacting gc is used. This patch takes a more conservative approach: all data sections except C strings align to word size. - - - - - 08ba8720 by Andreas Klebinger at 2023-01-30T21:18:45-05:00 ghc-the-library: Retain cafs in both static in dynamic builds. We use keepCAFsForGHCi.c to force -fkeep-cafs behaviour by using a __attribute__((constructor)) function. This broke for static builds where the linker discarded the object file since it was not reverenced from any exported code. We fix this by asserting that the flag is enabled using a function in the same module as the constructor. Which causes the object file to be retained by the linker, which in turn causes the constructor the be run in static builds. This changes nothing for dynamic builds using the ghc library. But causes static to also retain CAFs (as we expect them to). Fixes #22417. ------------------------- Metric Decrease: T21839r ------------------------- - - - - - 20598ef6 by Ryan Scott at 2023-01-30T21:19:20-05:00 Handle `type data` properly in tyThingParent_maybe Unlike most other data constructors, data constructors declared with `type data` are represented in `TyThing`s as `ATyCon` rather than `ADataCon`. The `ATyCon` case in `tyThingParent_maybe` previously did not consider the possibility of the underlying `TyCon` being a promoted data constructor, which led to the oddities observed in #22817. This patch adds a dedicated special case in `tyThingParent_maybe`'s `ATyCon` case for `type data` data constructors to fix these oddities. Fixes #22817. - - - - - 2f145052 by Ryan Scott at 2023-01-30T21:19:56-05:00 Fix two bugs in TypeData TH reification This patch fixes two issues in the way that `type data` declarations were reified with Template Haskell: * `type data` data constructors are now properly reified using `DataConI`. This is accomplished with a special case in `reifyTyCon`. Fixes #22818. * `type data` type constructors are now reified in `reifyTyCon` using `TypeDataD` instead of `DataD`. Fixes #22819. - - - - - d0f34f25 by Simon Peyton Jones at 2023-01-30T21:20:35-05:00 Take account of loop breakers in specLookupRule The key change is that in GHC.Core.Opt.Specialise.specLookupRule we were using realIdUnfolding, which ignores the loop-breaker flag. When given a loop breaker, rule matching therefore looped infinitely -- #22802. In fixing this I refactored a bit. * Define GHC.Core.InScopeEnv as a data type, and use it. (Previously it was a pair: hard to grep for.) * Put several functions returning an IdUnfoldingFun into GHC.Types.Id, namely idUnfolding alwaysActiveUnfoldingFun, whenActiveUnfoldingFun, noUnfoldingFun and use them. (The are all loop-breaker aware.) - - - - - de963cb6 by Matthew Pickering at 2023-01-30T21:21:11-05:00 ci: Remove FreeBSD job from release pipelines We no longer attempt to build or distribute this release - - - - - f26d27ec by Matthew Pickering at 2023-01-30T21:21:11-05:00 rel_eng: Add check to make sure that release jobs are downloaded by fetch-gitlab This check makes sure that if a job is a prefixed by "release-" then the script downloads it and understands how to map the job name to the platform. - - - - - 7619c0b4 by Matthew Pickering at 2023-01-30T21:21:11-05:00 rel_eng: Fix the name of the ubuntu-* jobs These were not uploaded for alpha1 Fixes #22844 - - - - - 68eb8877 by Matthew Pickering at 2023-01-30T21:21:11-05:00 gen_ci: Only consider release jobs for job metadata In particular we do not have a release job for FreeBSD so the generation of the platform mapping was failing. - - - - - b69461a0 by Jason Shipman at 2023-01-30T21:21:50-05:00 User's guide: Clarify overlapping instance candidate elimination This commit updates the user's guide section on overlapping instance candidate elimination to use "or" verbiage instead of "either/or" in regards to the current pair of candidates' being overlappable or overlapping. "Either IX is overlappable, or IY is overlapping" can cause confusion as it suggests "Either IX is overlappable, or IY is overlapping, but not both". This was initially discussed on this Discourse topic: https://discourse.haskell.org/t/clarification-on-overlapping-instance-candidate-elimination/5677 - - - - - 7cbdaad0 by Matthew Pickering at 2023-01-31T07:53:53-05:00 Fixes for cabal-reinstall CI job * Allow filepath to be reinstalled * Bump some version bounds to allow newer versions of libraries * Rework testing logic to avoid "install --lib" and package env files Fixes #22344 - - - - - fd8f32bf by Cheng Shao at 2023-01-31T07:54:29-05:00 rts: prevent potential divide-by-zero when tickInterval=0 This patch fixes a few places in RtsFlags.c that may result in divide-by-zero error when tickInterval=0, which is the default on wasm. Fixes #22603. - - - - - 085a6db6 by Joachim Breitner at 2023-01-31T07:55:05-05:00 Update note at beginning of GHC.Builtin.NAmes some things have been renamed since it was written, it seems. - - - - - 7716cbe6 by Cheng Shao at 2023-01-31T07:55:41-05:00 testsuite: use tgamma for cg007 gamma is a glibc-only deprecated function, use tgamma instead. It's required for fixing cg007 when testing the wasm unregisterised codegen. - - - - - 19c1fbcd by doyougnu at 2023-01-31T13:08:03-05:00 InfoTableProv: ShortText --> ShortByteString - - - - - 765fab98 by doyougnu at 2023-01-31T13:08:03-05:00 FastString: add fastStringToShorText - - - - - a83c810d by Simon Peyton Jones at 2023-01-31T13:08:38-05:00 Improve exprOkForSpeculation for classops This patch fixes #22745 and #15205, which are about GHC's failure to discard unnecessary superclass selections that yield coercions. See GHC.Core.Utils Note [exprOkForSpeculation and type classes] The main changes are: * Write new Note [NON-BOTTOM_DICTS invariant] in GHC.Core, and refer to it * Define new function isTerminatingType, to identify those guaranteed-terminating dictionary types. * exprOkForSpeculation has a new (very simple) case for ClassOpId * ClassOpId has a new field that says if the return type is an unlifted type, or a terminating type. This was surprisingly tricky to get right. In particular note that unlifted types are not terminating types; you can write an expression of unlifted type, that diverges. Not so for dictionaries (or, more precisely, for the dictionaries that GHC constructs). Metric Decrease: LargeRecord - - - - - f83374f8 by Krzysztof Gogolewski at 2023-01-31T13:09:14-05:00 Support "unusable UNPACK pragma" warning with -O0 Fixes #11270 - - - - - a2d814dc by Ben Gamari at 2023-01-31T13:09:50-05:00 configure: Always create the VERSION file Teach the `configure` script to create the `VERSION` file. This will serve as the stable interface to allow the user to determine the version number of a working tree. Fixes #22322. - - - - - 5618fc21 by sheaf at 2023-01-31T15:51:06-05:00 Cmm: track the type of global registers This patch tracks the type of Cmm global registers. This is needed in order to lint uses of polymorphic registers, such as SIMD vector registers that can be used both for floating-point and integer values. This changes allows us to refactor VanillaReg to not store VGcPtr, as that information is instead stored in the type of the usage of the register. Fixes #22297 - - - - - 78b99430 by sheaf at 2023-01-31T15:51:06-05:00 Revert "Cmm Lint: relax SIMD register assignment check" This reverts commit 3be48877, which weakened a Cmm Lint check involving SIMD vectors. Now that we keep track of the type a global register is used at, we can restore the original stronger check. - - - - - be417a47 by Ben Gamari at 2023-01-31T15:51:45-05:00 nativeGen/AArch64: Fix debugging output Previously various panics would rely on a half-written Show instance, leading to very unhelpful errors. Fix this. See #22798. - - - - - 30989d13 by Ben Gamari at 2023-01-31T15:51:45-05:00 nativeGen: Teach graph-colouring allocator that x18 is unusable Previously trivColourable for AArch64 claimed that at 18 registers were trivially-colourable. This is incorrect as x18 is reserved by the platform on AArch64/Darwin. See #22798. - - - - - 7566fd9d by Ben Gamari at 2023-01-31T15:51:45-05:00 nativeGen/AArch64: Fix graph-colouring allocator Previously various `Instr` queries used by the graph-colouring allocator failed to handle a few pseudo-instructions. This manifested in compiler panicks while compiling `SHA`, which uses `-fregs-graph`. Fixes #22798. - - - - - 2cb500a5 by Ben Gamari at 2023-01-31T15:51:45-05:00 testsuite: Add regression test for #22798 - - - - - 03d693b2 by Ben Gamari at 2023-01-31T15:52:32-05:00 Revert "Hadrian: fix doc generation" This is too large of a hammer. This reverts commit 5640cb1d84d3cce4ce0a9e90d29b2b20d2b38c2f. - - - - - f838815c by Ben Gamari at 2023-01-31T15:52:32-05:00 hadrian: Sphinx docs require templated cabal files The package-version discovery logic in `doc/users_guide/package_versions.py` uses packages' cabal files to determine package versions. Teach Sphinx about these dependencies in cases where the cabal files are generated by templates. - - - - - 2e48c19a by Ben Gamari at 2023-01-31T15:52:32-05:00 hadrian: Refactor templating logic This refactors Hadrian's autoconf-style templating logic to be explicit about which interpolation variables should be substituted in which files. This clears the way to fix #22714 without incurring rule cycles. - - - - - 93f0e3c4 by Ben Gamari at 2023-01-31T15:52:33-05:00 hadrian: Substitute LIBRARY_*_VERSION variables This teaches Hadrian to substitute the `LIBRARY_*_VERSION` variables in `libraries/prologue.txt`, fixing #22714. Fixes #22714. - - - - - 22089f69 by Ben Gamari at 2023-01-31T20:46:27-05:00 Bump transformers submodule to 0.6.0.6 Fixes #22862. - - - - - f0eefa3c by Cheng Shao at 2023-01-31T20:47:03-05:00 compiler: properly handle non-word-sized CmmSwitch scrutinees in the wasm NCG Currently, the wasm NCG has an implicit assumption: all CmmSwitch scrutinees are 32-bit integers. This is not always true; #22864 is one counter-example with a 64-bit scrutinee. This patch fixes the logic by explicitly converting the scrutinee to a word that can be used as a br_table operand. Fixes #22871. Also includes a regression test. - - - - - 9f95db54 by Simon Peyton Jones at 2023-02-01T08:55:08+00:00 Improve treatment of type applications in patterns This patch fixes a subtle bug in the typechecking of type applications in patterns, e.g. f (MkT @Int @a x y) = ... See Note [Type applications in patterns] in GHC.Tc.Gen.Pat. This fixes #19847, #22383, #19577, #21501 - - - - - 955a99ea by Simon Peyton Jones at 2023-02-01T12:31:23-05:00 Treat existentials correctly in dubiousDataConInstArgTys Consider (#22849) data T a where MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a Then dubiousDataConInstArgTys MkT [Type, Foo] should return [Foo (ix::Type)] NOT [Foo (ix::k)] A bit of an obscure case, but it's an outright bug, and the fix is easy. - - - - - 0cc16aaf by Matthew Pickering at 2023-02-01T12:31:58-05:00 Bump supported LLVM range from 10 through 15 to 11 through 16 LLVM 15 turns on the new pass manager by default, which we have yet to migrate to so for new we pass the `-enable-new-pm-0` flag in our llvm-passes flag. LLVM 11 was the first version to support the `-enable-new-pm` flag so we bump the lowest supported version to 11. Our CI jobs are using LLVM 12 so they should continue to work despite this bump to the lower bound. Fixes #21936 - - - - - f94f1450 by Matthew Pickering at 2023-02-01T12:31:58-05:00 Bump DOCKER_REV to use alpine image without LLVM installed alpine_3_12 only supports LLVM 10, which is now outside the supported version range. - - - - - 083e26ed by Matthew Pickering at 2023-02-01T17:43:21-05:00 Remove tracing OPTIONS_GHC These were accidentally left over from !9542 - - - - - 354aa47d by Teo Camarasu at 2023-02-01T17:44:00-05:00 doc: fix gcdetails_block_fragmentation_bytes since annotation - - - - - 61ce5bf6 by Jaro Reinders at 2023-02-02T00:15:30-05:00 compiler: Implement higher order patterns in the rule matcher This implements proposal 555 and closes ticket #22465. See the proposal and ticket for motivation. The core changes of this patch are in the GHC.Core.Rules.match function and they are explained in the Note [Matching higher order patterns]. - - - - - 394b91ce by doyougnu at 2023-02-02T00:16:10-05:00 CI: JavaScript backend runs testsuite This MR runs the testsuite for the JS backend. Note that this is a temporary solution until !9515 is merged. Key point: The CI runs hadrian on the built cross compiler _but not_ on the bindist. Other Highlights: - stm submodule gets a bump to mark tests as broken - several tests are marked as broken or are fixed by adding more - conditions to their test runner instance. List of working commit messages: CI: test cross target _and_ emulator CI: JS: Try run testsuite with hadrian JS.CI: cleanup and simplify hadrian invocation use single bracket, print info JS CI: remove call to test_compiler from hadrian don't build haddock JS: mark more tests as broken Tracked in https://gitlab.haskell.org/ghc/ghc/-/issues/22576 JS testsuite: don't skip sum_mod test Its expected to fail, yet we skipped it which automatically makes it succeed leading to an unexpected success, JS testsuite: don't mark T12035j as skip leads to an unexpected pass JS testsuite: remove broken on T14075 leads to unexpected pass JS testsuite: mark more tests as broken JS testsuite: mark T11760 in base as broken JS testsuite: mark ManyUnbSums broken submodules: bump process and hpc for JS tests Both submodules has needed tests skipped or marked broken for th JS backend. This commit now adds these changes to GHC. See: HPC: https://gitlab.haskell.org/hpc/hpc/-/merge_requests/21 Process: https://github.com/haskell/process/pull/268 remove js_broken on now passing tests separate wasm and js backend ci test: T11760: add threaded, non-moving only_ways test: T10296a add req_c T13894: skip for JS backend tests: jspace, T22333: mark as js_broken(22573) test: T22513i mark as req_th stm submodule: mark stm055, T16707 broken for JS tests: js_broken(22374) on unpack_sums_6, T12010 dont run diff on JS CI, cleanup fixup: More CI cleanup fix: align text to master fix: align exceptions submodule to master CI: Bump DOCKER_REV Bump to ci-images commit that has a deb11 build with node. Required for !9552 testsuite: mark T22669 as js_skip See #22669 This test tests that .o-boot files aren't created when run in using the interpreter backend. Thus this is not relevant for the JS backend. testsuite: mark T22671 as broken on JS See #22835 base.testsuite: mark Chan002 fragile for JS see #22836 revert: submodule process bump bump stm submodule New hash includes skips for the JS backend. testsuite: mark RnPatternSynonymFail broken on JS Requires TH: - see !9779 - and #22261 compiler: GHC.hs ifdef import Utils.Panic.Plain - - - - - 1ffe770c by Cheng Shao at 2023-02-02T09:40:38+00:00 docs: 9.6 release notes for wasm backend - - - - - 0ada4547 by Matthew Pickering at 2023-02-02T11:39:44-05:00 Disable unfolding sharing for interface files with core definitions Ticket #22807 pointed out that the RHS sharing was not compatible with -fignore-interface-pragmas because the flag would remove unfoldings from identifiers before the `extra-decls` field was populated. For the 9.6 timescale the only solution is to disable this sharing, which will make interface files bigger but this is acceptable for the first release of `-fwrite-if-simplified-core`. For 9.8 it would be good to fix this by implementing #20056 due to the large number of other bugs that would fix. I also improved the error message in tc_iface_binding to avoid the "no match in record selector" error but it should never happen now as the entire sharing logic is disabled. Also added the currently broken test for #22807 which could be fixed by !6080 Fixes #22807 - - - - - 7e2d3eb5 by lrzlin at 2023-02-03T05:23:27-05:00 Enable tables next to code for LoongArch64 - - - - - 2931712a by Wander Hillen at 2023-02-03T05:24:06-05:00 Move pthread and timerfd ticker implementations to separate files - - - - - 41c4baf8 by Ben Gamari at 2023-02-03T05:24:44-05:00 base: Fix Note references in GHC.IO.Handle.Types - - - - - 31358198 by Bodigrim at 2023-02-03T05:25:22-05:00 Bump submodule containers to 0.6.7 Metric Decrease: ManyConstructors T10421 T12425 T12707 T13035 T13379 T15164 T1969 T783 T9198 T9961 WWRec - - - - - 8feb9301 by Ben Gamari at 2023-02-03T05:25:59-05:00 gitlab-ci: Eliminate redundant ghc --info output Previously ci.sh would emit the output of `ghc --info` every time it ran when using the nix toolchain. This produced a significant amount of noise. See #22861. - - - - - de1d1512 by Ryan Scott at 2023-02-03T14:07:30-05:00 Windows: Remove mingwex dependency The clang based toolchain uses ucrt as its math library and so mingwex is no longer needed. In fact using mingwex will cause incompatibilities as the default routines in both have differing ULPs and string formatting modifiers. ``` $ LIBRARY_PATH=/mingw64/lib ghc/_build/stage1/bin/ghc Bug.hs -fforce-recomp && ./Bug.exe [1 of 2] Compiling Main ( Bug.hs, Bug.o ) ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `__imp___p__environ' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `__hscore_get_errno' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_ForeignziCziError_errnoToIOError_info' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziWindows_failIf2_closure' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziIOziEncodingziCodePageziAPI_mkCodePageEncoding_info' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziIOziEncodingziCodePage_currentCodePage_closure' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziIOziEncoding_getForeignEncoding_closure' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_ForeignziCziString_withCStringLen1_info' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziIOziHandleziInternals_zdwflushCharReadBuffer_info' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziIOziHandleziText_hGetBuf1_info' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziFingerprint_fingerprintString_closure' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_DataziTypeableziInternal_mkTrCon_closure' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziException_errorCallWithCallStackException_closure' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\base-4.17.0.0\libHSbase-4.17.0.0.a: unknown symbol `base_GHCziErr_error_info' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\template-haskell-2.19.0.0\libHStemplate-haskell-2.19.0.0.a: unknown symbol `base_DataziMaybe_fromJust1_info' ghc.exe: | C:\Users\winferno\Software\ghc\_build\stage1\lib\x86_64-windows-ghc-9.5.20220908\template-haskell-2.19.0.0\libHStemplate-haskell-2.19.0.0.a: unknown symbol `templatezmhaskell_LanguageziHaskellziTHziSyntax_IntPrimL_con_info' ghc.exe: ^^ Could not load 'templatezmhaskell_LanguageziHaskellziTHziLibziInternal_stringL_closure', dependency unresolved. See top entry above. <no location info>: error: GHC.ByteCode.Linker.lookupCE During interactive linking, GHCi couldn't find the following symbol: templatezmhaskell_LanguageziHaskellziTHziLibziInternal_stringL_closure This may be due to you not asking GHCi to load extra object files, archives or DLLs needed by your current session. Restart GHCi, specifying the missing library using the -L/path/to/object/dir and -lmissinglibname flags, or simply by naming the relevant files on the GHCi command line. Alternatively, this link failure might indicate a bug in GHCi. If you suspect the latter, please report this as a GHC bug: https://www.haskell.org/ghc/reportabug ``` - - - - - 48e39195 by Tamar Christina at 2023-02-03T14:07:30-05:00 linker: Fix BFD import libraries This commit fixes the BFD style import library support in the runtime linker. This was accidentally broken during the refactoring to clang and went unnoticed because clang itself is unable to generate the BFD style import libraries. With this change we can not link against both GCC or Clang produced libraries again and intermix code produced by both compilers. - - - - - b2bb3e62 by Ben Gamari at 2023-02-03T14:07:30-05:00 Bump Windows toolchain Updates to LLVM 14, hopefully fixing #21964. - - - - - bf3f88a1 by Andreas Klebinger at 2023-02-03T14:08:07-05:00 Fix CallerCC potentially shadowing other cost centres. Add a CallerCC cost centre flavour for cost centres added by the CallerCC pass. This avoids potential accidental shadowing between CCs added by user annotations and ones added by CallerCC. - - - - - faea4bcd by j at 2023-02-03T14:08:47-05:00 Disable several ignore-warning flags in genapply. - - - - - 25537dfd by Ben Gamari at 2023-02-04T04:12:57-05:00 Revert "Use fix-sized bit-fiddling primops for fixed size boxed types" This reverts commit 4512ad2d6a8e65ea43c86c816411cb13b822f674. This was never applied to master/9.6 originally. (cherry picked from commit a44bdc2720015c03d57f470b759ece7fab29a57a) - - - - - 7612dc71 by Krzysztof Gogolewski at 2023-02-04T04:13:34-05:00 Minor refactor * Introduce refactorDupsOn f = refactorDups (comparing f) * Make mkBigTupleCase and coreCaseTuple monadic. Every call to those functions was preceded by calling newUniqueSupply. * Use mkUserLocalOrCoVar, which is equivalent to combining mkLocalIdOrCoVar with mkInternalName. - - - - - 5a54ac0b by Bodigrim at 2023-02-04T18:48:32-05:00 Fix colors in emacs terminal - - - - - 3c0f0c6d by Bodigrim at 2023-02-04T18:49:11-05:00 base changelog: move entries which were not backported to ghc-9.6 to base-4.19 section - - - - - b18fbf52 by Josh Meredith at 2023-02-06T07:47:57+00:00 Update JavaScript fileStat to match Emscripten layout - - - - - 6636b670 by Sylvain Henry at 2023-02-06T09:43:21-05:00 JS: replace "js" architecture with "javascript" Despite Cabal supporting any architecture name, `cabal --check` only supports a few built-in ones. Sadly `cabal --check` is used by Hackage hence using any non built-in name in a package (e.g. `arch(js)`) is rejected and the package is prevented from being uploaded on Hackage. Luckily built-in support for the `javascript` architecture was added for GHCJS a while ago. In order to allow newer `base` to be uploaded on Hackage we make the switch from `js` to `javascript` architecture. Fixes #22740. Co-authored-by: Ben Gamari <ben at smart-cactus.org> - - - - - 77a8234c by Luite Stegeman at 2023-02-06T09:43:59-05:00 Fix marking async exceptions in the JS backend Async exceptions are posted as a pair of the exception and the thread object. This fixes the marking pass to correctly follow the two elements of the pair. Potentially fixes #22836 - - - - - 3e09cf82 by Jan Hrček at 2023-02-06T09:44:38-05:00 Remove extraneous word in Roles user guide - - - - - b17fb3d9 by sheaf at 2023-02-07T10:51:33-05:00 Don't allow . in overloaded labels This patch removes . from the list of allowed characters in a non-quoted overloaded label, as it was realised this steals syntax, e.g. (#.). Users who want this functionality will have to add quotes around the label, e.g. `#"17.28"`. Fixes #22821 - - - - - 5dce04ee by romes at 2023-02-07T10:52:10-05:00 Update kinds in comments in GHC.Core.TyCon Use `Type` instead of star kind (*) Fix comment with incorrect kind * to have kind `Constraint` - - - - - 92916194 by Ben Gamari at 2023-02-07T10:52:48-05:00 Revert "Use fix-sized equality primops for fixed size boxed types" This reverts commit 024020c38126f3ce326ff56906d53525bc71690c. This was never applied to master/9.6 originally. See #20405 for why using these primops is a bad idea. (cherry picked from commit b1d109ad542e4c37ae5af6ace71baf2cb509d865) - - - - - c1670c6b by Sylvain Henry at 2023-02-07T21:25:18-05:00 JS: avoid head/tail and unpackFS - - - - - a9912de7 by Krzysztof Gogolewski at 2023-02-07T21:25:53-05:00 testsuite: Fix Python warnings (#22856) - - - - - 9ee761bf by sheaf at 2023-02-08T14:40:40-05:00 Fix tyvar scoping within class SPECIALISE pragmas Type variables from class/instance headers scope over class/instance method type signatures, but DO NOT scope over the type signatures in SPECIALISE and SPECIALISE instance pragmas. The logic in GHC.Rename.Bind.rnMethodBinds correctly accounted for SPECIALISE inline pragmas, but forgot to apply the same treatment to method SPECIALISE pragmas, which lead to a Core Lint failure with an out-of-scope type variable. This patch makes sure we apply the same logic for both cases. Fixes #22913 - - - - - 7eac2468 by Matthew Pickering at 2023-02-08T14:41:17-05:00 Revert "Don't keep exit join points so much" This reverts commit caced75765472a1a94453f2e5a439dba0d04a265. It seems the patch "Don't keep exit join points so much" is causing wide-spread regressions in the bytestring library benchmarks. If I revert it then the 9.6 numbers are better on average than 9.4. See https://gitlab.haskell.org/ghc/ghc/-/issues/22893#note_479525 ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp MultiLayerModules MultiLayerModulesRecomp MultiLayerModulesTH_Make T12150 T13386 T13719 T21839c T3294 parsing001 ------------------------- - - - - - 633f2799 by Cheng Shao at 2023-02-08T18:42:16-05:00 testsuite: remove config.use_threads This patch simplifies the testsuite driver by removing the use_threads config field. It's just a degenerate case of threads=1. - - - - - ca6673e3 by Cheng Shao at 2023-02-08T18:42:16-05:00 testsuite: use concurrent.futures.ThreadPoolExecutor in the driver The testsuite driver used to create one thread per test case, and explicitly use semaphore and locks for rate limiting and synchronization. This is a bad practice in any language, and occasionally may result in livelock conditions (e.g. #22889). This patch uses concurrent.futures.ThreadPoolExecutor for scheduling test case runs, which is simpler and more robust. - - - - - f22cce70 by Alan Zimmerman at 2023-02-08T18:42:51-05:00 EPA: Comment between module and where should be in header comments Do not apply the heuristic to associate a comment with a prior declaration for the first declaration in the file. Closes #22919 - - - - - d69ecac2 by Josh Meredith at 2023-02-09T03:24:05-05:00 JS generated refs: update testsuite conditions - - - - - 2ea1a6bc by sheaf at 2023-02-09T03:24:44-05:00 Bump transformers to 0.6.1.0 This allows us to avoid orphans for Foldable1 instances, fixing #22898. Updates transformers submodule. - - - - - d9d0c28d by konsumlamm at 2023-02-09T14:07:48-05:00 Update `Data.List.singleton` doc comment - - - - - fe9cd6ef by Ben Gamari at 2023-02-09T14:08:23-05:00 gitlab-template: Emphasize `user facing` label My sense is that the current mention of the ~"user facing" label is overlooked by many MR authors. Let's move this point up in the list to make it more likely that it is seen. Also rephrase some of the points. - - - - - e45eb828 by Simon Peyton Jones at 2023-02-10T06:51:28-05:00 Refactor the simplifier a bit to fix #22761 The core change in this commit, which fixes #22761, is that * In a Core rule, ru_rhs is always occ-analysed. This means adding a couple of calls to occurAnalyseExpr when building a Rule, in * GHC.Core.Rules.mkRule * GHC.Core.Opt.Simplify.Iteration.simplRules But diagosing the bug made me stare carefully at the code of the Simplifier, and I ended up doing some only-loosely-related refactoring. * I think that RULES could be lost because not every code path did addBndrRules * The code around lambdas was very convoluted It's mainly moving deck chairs around, but I like it more now. - - - - - 11e0cacb by Rebecca Turner at 2023-02-10T06:52:09-05:00 Detect the `mold` linker Enables support for the `mold` linker by rui314. - - - - - 59556235 by parsonsmatt at 2023-02-10T09:53:11-05:00 Add Lift instance for Fixed - - - - - c44e5f30 by Sylvain Henry at 2023-02-10T09:53:51-05:00 Testsuite: decrease length001 timeout for JS (#22921) - - - - - 133516af by Zubin Duggal at 2023-02-10T09:54:27-05:00 compiler: Use NamedFieldPuns for `ModIface_` and `ModIfaceBackend` `NFData` instances This is a minor refactor that makes it easy to add and remove fields from `ModIface_` and `ModIfaceBackend`. Also change the formatting to make it clear exactly which fields are fully forced with `rnf` - - - - - 1e9eac1c by Matthew Pickering at 2023-02-13T11:36:41+01:00 Refresh profiling docs I went through the whole of the profiling docs and tried to amend them to reflect current best practices and tooling. In particular I removed some old references to tools such as hp2any and replaced them with references to eventlog2html. - - - - - da208b9a by Matthew Pickering at 2023-02-13T11:36:41+01:00 docs: Add section about profiling and foreign calls Previously there was no documentation for how foreign calls interacted with the profiler. This can be quite confusing for users so getting it into the user guide is the first step to a potentially better solution. See the ticket for more insightful discussion. Fixes #21764 - - - - - 081640f1 by Bodigrim at 2023-02-13T12:51:52-05:00 Document that -fproc-alignment was introduced only in GHC 8.6 - - - - - 16adc349 by Sven Tennie at 2023-02-14T11:26:31-05:00 Add clangd flag to include generated header files This enables clangd to correctly check C files that import Rts.h. (The added include directory contains ghcautoconf.h et. al.) - - - - - c399ccd9 by amesgen at 2023-02-14T11:27:14-05:00 Mention new `Foreign.Marshal.Pool` implementation in User's Guide - - - - - b9282cf7 by Ben Gamari at 2023-02-14T11:27:50-05:00 upload_ghc_libs: More control over which packages to operate on Here we add a `--skip` flag to `upload_ghc_libs`, making it easier to limit which packages to upload. This is often necessary when one package is not uploadable (e.g. see #22740). - - - - - aa3a262d by PHO at 2023-02-14T11:28:29-05:00 Assume platforms support rpaths if they use either ELF or Mach-O Not only Linux, Darwin, and FreeBSD support rpaths. Determine the usability of rpaths based on the object format, not on OS. - - - - - 47716024 by PHO at 2023-02-14T11:29:09-05:00 RTS linker: Improve compatibility with NetBSD 1. Hint address to NetBSD mmap(2) has a different semantics from that of Linux. When a hint address is provided, mmap(2) searches for a free region at or below the hint but *never* above it. This means we can't reliably search for free regions incrementally on the userland, especially when ASLR is enabled. Let the kernel do it for us if we don't care where the mapped address is going to be. 2. NetBSD not only hates to map pages as rwx, but also disallows to switch pages from rw- to r-x unless the intention is declared when pages are initially requested. This means we need a new MemoryAccess mode for pages that are going to be changed to r-x. - - - - - 11de324a by Li-yao Xia at 2023-02-14T11:29:49-05:00 base: Move changelog entry to its place - - - - - 75930424 by Ben Gamari at 2023-02-14T11:30:27-05:00 nativeGen/AArch64: Emit Atomic{Read,Write} inline Previously the AtomicRead and AtomicWrite operations were emitted as out-of-line calls. However, these tend to be very important for performance, especially the RELAXED case (which only exists for ThreadSanitizer checking). Fixes #22115. - - - - - d6411d6c by Andreas Klebinger at 2023-02-14T11:31:04-05:00 Fix some correctness issues around tag inference when targeting the bytecode generator. * Let binders are now always assumed untagged for bytecode. * Imported referenced are now always assumed to be untagged for bytecode. Fixes #22840 - - - - - 9fb4ca89 by sheaf at 2023-02-14T11:31:49-05:00 Introduce warning for loopy superclass solve Commit aed1974e completely re-engineered the treatment of loopy superclass dictionaries in instance declarations. Unfortunately, it has the potential to break (albeit in a rather minor way) user code. To alleviate migration concerns, this commit re-introduces the old behaviour. Any reliance on this old behaviour triggers a warning, controlled by `-Wloopy-superclass-solve`. The warning text explains that GHC might produce bottoming evidence, and provides a migration strategy. This allows us to provide a graceful migration period, alerting users when they are relying on this unsound behaviour. Fixes #22912 #22891 #20666 #22894 #22905 - - - - - 1928c7f3 by Cheng Shao at 2023-02-14T11:32:26-05:00 rts: make it possible to change mblock size on 32-bit targets The MBLOCK_SHIFT macro must be the single source of truth for defining the mblock size, and changing it should only affect performance, not correctness. This patch makes it truly possible to reconfigure mblock size, at least on 32-bit targets, by fixing places which implicitly relied on the previous MBLOCK_SHIFT constant. Fixes #22901. - - - - - 78aa3b39 by Simon Hengel at 2023-02-14T11:33:06-05:00 Update outdated references to notes - - - - - e8baecd2 by meooow25 at 2023-02-14T11:33:49-05:00 Documentation: Improve Foldable1 documentation * Explain foldrMap1, foldlMap1, foldlMap1', and foldrMap1' in greater detail, the text is mostly adapted from documentation of Foldable. * Describe foldr1, foldl1, foldl1' and foldr1' in terms of the above functions instead of redoing the full explanation. * Small updates to documentation of fold1, foldMap1 and toNonEmpty, again adapting from Foldable. * Update the foldMap1 example to lists instead of Sum since this is recommended for lazy right-associative folds. Fixes #22847 - - - - - 85a1a575 by romes at 2023-02-14T11:34:25-05:00 fix: Mark ghci Prelude import as implicit Fixes #22829 In GHCi, we were creating an import declaration for Prelude but we were not setting it as an implicit declaration. Therefore, ghci's import of Prelude triggered -Wmissing-import-lists. Adds regression test T22829 to testsuite - - - - - 3b019a7a by Cheng Shao at 2023-02-14T11:35:03-05:00 compiler: fix generateCgIPEStub for no-tables-next-to-code builds generateCgIPEStub already correctly implements the CmmTick finding logic for when tables-next-to-code is on/off, but it used the wrong predicate to decide when to switch between the two. Previously it switches based on whether the codegen is unregisterised, but there do exist registerised builds that disable tables-next-to-code! This patch corrects that problem. Fixes #22896. - - - - - 08c0822c by doyougnu at 2023-02-15T00:16:39-05:00 docs: release notes, user guide: add js backend Follow up from #21078 - - - - - 79d8fd65 by Bryan Richter at 2023-02-15T00:17:15-05:00 Allow failure in nightly-x86_64-linux-deb10-no_tntc-validate See #22343 - - - - - 9ca51f9e by Cheng Shao at 2023-02-15T00:17:53-05:00 rts: add the rts_clearMemory function This patch adds the rts_clearMemory function that does its best to zero out unused RTS memory for a wasm backend use case. See the comment above rts_clearMemory() prototype declaration for more detailed explanation. Closes #22920. - - - - - 26df73fb by Oleg Grenrus at 2023-02-15T22:20:57-05:00 Add -single-threaded flag to force single threaded rts This is the small part of implementing https://github.com/ghc-proposals/ghc-proposals/pull/240 - - - - - 631c6c72 by Cheng Shao at 2023-02-16T06:43:09-05:00 docs: add a section for the wasm backend Fixes #22658 - - - - - 1878e0bd by Bryan Richter at 2023-02-16T06:43:47-05:00 tests: Mark T12903 fragile everywhere See #21184 - - - - - b9420eac by Bryan Richter at 2023-02-16T06:43:47-05:00 Mark all T5435 variants as fragile See #22970. - - - - - df3d94bd by Sylvain Henry at 2023-02-16T06:44:33-05:00 Testsuite: mark T13167 as fragile for JS (#22921) - - - - - 324e925b by Sylvain Henry at 2023-02-16T06:45:15-05:00 JS: disable debugging info for heap objects - - - - - 518af814 by Josh Meredith at 2023-02-16T10:16:32-05:00 Factor JS Rts generation for h$c{_,0,1,2} into h$c{n} and improve name caching - - - - - 34cd308e by Ben Gamari at 2023-02-16T10:17:08-05:00 base: Note move of GHC.Stack.CCS.whereFrom to GHC.InfoProv in changelog Fixes #22883. - - - - - 12965aba by Simon Peyton Jones at 2023-02-16T10:17:46-05:00 Narrow the dont-decompose-newtype test Following #22924 this patch narrows the test that stops us decomposing newtypes. The key change is the use of noGivenNewtypeReprEqs in GHC.Tc.Solver.Canonical.canTyConApp. We went to and fro on the solution, as you can see in #22924. The result is carefully documented in Note [Decomoposing newtype equalities] On the way I had revert most of commit 3e827c3f74ef76d90d79ab6c4e71aa954a1a6b90 Author: Richard Eisenberg <rae at cs.brynmawr.edu> Date: Mon Dec 5 10:14:02 2022 -0500 Do newtype unwrapping in the canonicaliser and rewriter See Note [Unwrap newtypes first], which has the details. It turns out that (a) 3e827c3f makes GHC behave worse on some recursive newtypes (see one of the tests on this commit) (b) the finer-grained test (namely noGivenNewtypeReprEqs) renders 3e827c3f unnecessary - - - - - 5b038888 by Bodigrim at 2023-02-16T10:18:24-05:00 Documentation: add an example of SPEC usage - - - - - 681e0e8c by sheaf at 2023-02-16T14:09:56-05:00 No default finalizer exception handler Commit cfc8e2e2 introduced a mechanism for handling of exceptions that occur during Handle finalization, and 372cf730 set the default handler to print out the error to stderr. However, #21680 pointed out we might not want to set this by default, as it might pollute users' terminals with unwanted information. So, for the time being, the default handler discards the exception. Fixes #21680 - - - - - b3ac17ad by Matthew Pickering at 2023-02-16T14:10:31-05:00 unicode: Don't inline bitmap in generalCategory generalCategory contains a huge literal string but is marked INLINE, this will duplicate the string into any use site of generalCategory. In particular generalCategory is used in functions like isSpace and the literal gets inlined into this function which makes it massive. https://github.com/haskell/core-libraries-committee/issues/130 Fixes #22949 ------------------------- Metric Decrease: T4029 T18304 ------------------------- - - - - - 8988eeef by sheaf at 2023-02-16T20:32:27-05:00 Expand synonyms in RoughMap We were failing to expand type synonyms in the function GHC.Core.RoughMap.typeToRoughMatchLookupTc, even though the RoughMap infrastructure crucially relies on type synonym expansion to work. This patch adds the missing type-synonym expansion. Fixes #22985 - - - - - 3dd50e2f by Matthew Pickering at 2023-02-16T20:33:03-05:00 ghcup-metadata: Add test artifact Add the released testsuite tarball to the generated ghcup metadata. - - - - - c6a967d9 by Matthew Pickering at 2023-02-16T20:33:03-05:00 ghcup-metadata: Use Ubuntu and Rocky bindists Prefer to use the Ubuntu 20.04 and 18.04 binary distributions on Ubuntu and Linux Mint. Prefer to use the Rocky 8 binary distribution on unknown distributions. - - - - - be0b7209 by Matthew Pickering at 2023-02-17T09:37:16+00:00 Add INLINABLE pragmas to `generic*` functions in Data.OldList These functions are * recursive * overloaded So it's important to add an `INLINABLE` pragma to each so that they can be specialised at the use site when the specific numeric type is known. Adding these pragmas improves the LazyText replicate benchmark (see https://gitlab.haskell.org/ghc/ghc/-/issues/22886#note_481020) https://github.com/haskell/core-libraries-committee/issues/129 - - - - - a203ad85 by Sylvain Henry at 2023-02-17T15:59:16-05:00 Merge libiserv with ghci `libiserv` serves no purpose. As it depends on `ghci` and doesn't have more dependencies than the `ghci` package, its code could live in the `ghci` package too. This commit also moves most of the code from the `iserv` program into the `ghci` package as well so that it can be reused. This is especially useful for the implementation of TH for the JS backend (#22261, !9779). - - - - - 7080a93f by Simon Peyton Jones at 2023-02-20T12:06:32+01:00 Improve GHC.Tc.Gen.App.tcInstFun It wasn't behaving right when inst_final=False, and the function had no type variables f :: Foo => Int Rather a corner case, but we might as well do it right. Fixes #22908 Unexpectedly, three test cases (all using :type in GHCi) got slightly better output as a result: T17403, T14796, T12447 - - - - - 2592ab69 by Cheng Shao at 2023-02-20T10:35:30-05:00 compiler: fix cost centre profiling breakage in wasm NCG due to incorrect register mapping The wasm NCG used to map CCCS to a wasm global, based on the observation that CCCS is a transient register that's already handled by thread state load/store logic, so it doesn't need to be backed by the rCCCS field in the register table. Unfortunately, this is wrong, since even when Cmm execution hasn't yielded back to the scheduler, the Cmm code may call enterFunCCS, which does use rCCCS. This breaks cost centre profiling in a subtle way, resulting in inaccurate stack traces in some test cases. The fix is simple though: just remove the CCCS mapping. - - - - - 26243de1 by Alexis King at 2023-02-20T15:27:17-05:00 Handle top-level Addr# literals in the bytecode compiler Fixes #22376. - - - - - 0196cc2b by romes at 2023-02-20T15:27:52-05:00 fix: Explicitly flush stdout on plugin Because of #20791, the plugins tests often fail. This is a temporary fix to stop the tests from failing due to unflushed outputs on windows and the explicit flush should be removed when #20791 is fixed. - - - - - 4327d635 by Ryan Scott at 2023-02-20T20:44:34-05:00 Don't generate datacon wrappers for `type data` declarations Data constructor wrappers only make sense for _value_-level data constructors, but data constructors for `type data` declarations only exist at the _type_ level. This patch does the following: * The criteria in `GHC.Types.Id.Make.mkDataConRep` for whether a data constructor receives a wrapper now consider whether or not its parent data type was declared with `type data`, omitting a wrapper if this is the case. * Now that `type data` data constructors no longer receive wrappers, there is a spot of code in `refineDefaultAlt` that panics when it encounters a value headed by a `type data` type constructor. I've fixed this with a special case in `refineDefaultAlt` and expanded `Note [Refine DEFAULT case alternatives]` to explain why we do this. Fixes #22948. - - - - - 96dc58b9 by Ryan Scott at 2023-02-20T20:44:35-05:00 Treat type data declarations as empty when checking pattern-matching coverage The data constructors for a `type data` declaration don't exist at the value level, so we don't want GHC to warn users to match on them. Fixes #22964. - - - - - ff8e99f6 by Ryan Scott at 2023-02-20T20:44:35-05:00 Disallow `tagToEnum#` on `type data` types We don't want to allow users to conjure up values of a `type data` type using `tagToEnum#`, as these simply don't exist at the value level. - - - - - 8e765aff by Bodigrim at 2023-02-21T12:03:24-05:00 Bump submodule text to 2.0.2 - - - - - 172ff88f by Georgi Lyubenov at 2023-02-21T18:35:56-05:00 GHC proposal 496 - Nullary record wildcards This patch implements GHC proposal 496, which allows record wildcards to be used for nullary constructors, e.g. data A = MkA1 | MkA2 { fld1 :: Int } f :: A -> Int f (MkA1 {..}) = 0 f (MkA2 {..}) = fld1 To achieve this, we add arity information to the record field environment, so that we can accept a constructor which has no fields while continuing to reject non-record constructors with more than 1 field. See Note [Nullary constructors and empty record wildcards], as well as the more general overview in Note [Local constructor info in the renamer], both in the newly introduced GHC.Types.ConInfo module. Fixes #22161 - - - - - f70a0239 by sheaf at 2023-02-21T18:36:35-05:00 ghc-prim: levity-polymorphic array equality ops This patch changes the pointer-equality comparison operations in GHC.Prim.PtrEq to work with arrays of unlifted values, e.g. sameArray# :: forall {l} (a :: TYPE (BoxedRep l)). Array# a -> Array# a -> Int# Fixes #22976 - - - - - 9296660b by Andreas Klebinger at 2023-02-21T23:58:05-05:00 base: Correct @since annotation for FP<->Integral bit cast operations. Fixes #22708 - - - - - f11d9c27 by romes at 2023-02-21T23:58:42-05:00 fix: Update documentation links Closes #23008 Additionally batches some fixes to pointers to the Note [Wired-in units], and a typo in said note. - - - - - fb60339f by Bryan Richter at 2023-02-23T14:45:17+02:00 Propagate failure if unable to push notes - - - - - 8e170f86 by Alexis King at 2023-02-23T16:59:22-05:00 rts: Fix `prompt#` when profiling is enabled This commit also adds a new -Dk RTS option to the debug RTS to assist debugging continuation captures. Currently, the printed information is quite minimal, but more can be added in the future if it proves to be useful when debugging future issues. fixes #23001 - - - - - e9e7a00d by sheaf at 2023-02-23T17:00:01-05:00 Explicit migration timeline for loopy SC solving This patch updates the warning message introduced in commit 9fb4ca89bff9873e5f6a6849fa22a349c94deaae to specify an explicit migration timeline: GHC will no longer support this constraint solving mechanism starting from GHC 9.10. Fixes #22912 - - - - - 4eb9c234 by Sylvain Henry at 2023-02-24T17:27:45-05:00 JS: make some arithmetic primops faster (#22835) Don't use BigInt for wordAdd2, mulWord32, and timesInt32. Co-authored-by: Matthew Craven <5086-clyring at users.noreply.gitlab.haskell.org> - - - - - 92e76483 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump terminfo submodule to 0.4.1.6 - - - - - f229db14 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump unix submodule to 2.8.1.0 - - - - - 47bd48c1 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump deepseq submodule to 1.4.8.1 - - - - - d2012594 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump directory submodule to 1.3.8.1 - - - - - df6f70d1 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump process submodule to v1.6.17.0 - - - - - 4c869e48 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump hsc2hs submodule to 0.68.8 - - - - - 81d96642 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump array submodule to 0.5.4.0 - - - - - 6361f771 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump Cabal submodule to 3.9 pre-release - - - - - 4085fb6c by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump filepath submodule to 1.4.100.1 - - - - - 2bfad50f by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump haskeline submodule to 0.8.2.1 - - - - - fdc89a8d by Ben Gamari at 2023-02-24T21:29:32-05:00 gitlab-ci: Run nix-build with -v0 This significantly cuts down on the amount of noise in the job log. Addresses #22861. - - - - - 69fb0b13 by Aaron Allen at 2023-02-24T21:30:10-05:00 Fix ParallelListComp out of scope suggestion This patch makes it so vars from one block of a parallel list comprehension are not in scope in a subsequent block during type checking. This was causing GHC to emit a faulty suggestion when an out of scope variable shared the occ name of a var from a different block. Fixes #22940 - - - - - ece092d0 by Simon Peyton Jones at 2023-02-24T21:30:45-05:00 Fix shadowing bug in prepareAlts As #23012 showed, GHC.Core.Opt.Simplify.Utils.prepareAlts was using an OutType to construct an InAlt. When shadowing is in play, this is outright wrong. See Note [Shadowing in prepareAlts]. - - - - - 7825fef9 by Sylvain Henry at 2023-02-24T21:31:25-05:00 JS: Store CI perf results (fix #22923) - - - - - b56025f4 by Gergő Érdi at 2023-02-27T13:34:22+00:00 Don't specialise incoherent instance applications Using incoherent instances, there can be situations where two occurrences of the same overloaded function at the same type use two different instances (see #22448). For incoherently resolved instances, we must mark them with `nospec` to avoid the specialiser rewriting one to the other. This marking is done during the desugaring of the `WpEvApp` wrapper. Fixes #22448 Metric Increase: T15304 - - - - - d0c7bbed by Tom Ellis at 2023-02-27T20:04:07-05:00 Fix SCC grouping example - - - - - f84a8cd4 by Bryan Richter at 2023-02-28T05:58:37-05:00 Mark setnumcapabilities001 fragile - - - - - 29a04d6e by Bryan Richter at 2023-02-28T05:58:37-05:00 Allow nightly-x86_64-linux-deb10-validate+thread_sanitizer to fail See #22520 - - - - - 9fa54572 by Cheng Shao at 2023-02-28T05:59:15-05:00 ghc-prim: fix hs_cmpxchg64 function prototype hs_cmpxchg64 must return a StgWord64, otherwise incorrect runtime results of 64-bit MO_Cmpxchg will appear in 32-bit unregisterised builds, which go unnoticed at compile-time due to C implicit casting in .hc files. - - - - - 0c200ab7 by Simon Peyton Jones at 2023-02-28T11:10:31-05:00 Account for local rules in specImports As #23024 showed, in GHC.Core.Opt.Specialise.specImports, we were generating specialisations (a locally-define function) for imported functions; and then generating specialisations for those locally-defined functions. The RULE for the latter should be attached to the local Id, not put in the rules-for-imported-ids set. Fix is easy; similar to what happens in GHC.HsToCore.addExportFlagsAndRules - - - - - 8b77f9bf by Sylvain Henry at 2023-02-28T11:11:21-05:00 JS: fix for overlap with copyMutableByteArray# (#23033) The code wasn't taking into account some kind of overlap. cgrun070 has been extended to test the missing case. - - - - - 239202a2 by Sylvain Henry at 2023-02-28T11:12:03-05:00 Testsuite: replace some js_skip with req_cmm req_cmm is more informative than js_skip - - - - - 7192ef91 by Simon Peyton Jones at 2023-02-28T18:54:59-05:00 Take more care with unlifted bindings in the specialiser As #22998 showed, we were floating an unlifted binding to top level, which breaks a Core invariant. The fix is easy, albeit a little bit conservative. See Note [Care with unlifted bindings] in GHC.Core.Opt.Specialise - - - - - bb500e2a by Simon Peyton Jones at 2023-02-28T18:55:35-05:00 Account for TYPE vs CONSTRAINT in mkSelCo As #23018 showed, in mkRuntimeRepCo we need to account for coercions between TYPE and COERCION. See Note [mkRuntimeRepCo] in GHC.Core.Coercion. - - - - - 79ffa170 by Ben Gamari at 2023-03-01T04:17:20-05:00 hadrian: Add dependency from lib/settings to mk/config.mk In 81975ef375de07a0ea5a69596b2077d7f5959182 we attempted to fix #20253 by adding logic to the bindist Makefile to regenerate the `settings` file from information gleaned by the bindist `configure` script. However, this fix had no effect as `lib/settings` is shipped in the binary distribution (to allow in-place use of the binary distribution). As `lib/settings` already existed and its rule declared no dependencies, `make` would fail to use the added rule to regenerate it. Fix this by explicitly declaring a dependency from `lib/settings` on `mk/config.mk`. Fixes #22982. - - - - - a2a1a1c0 by Sebastian Graf at 2023-03-01T04:17:56-05:00 Revert the main payload of "Make `drop` and `dropWhile` fuse (#18964)" This reverts the bits affecting fusion of `drop` and `dropWhile` of commit 0f7588b5df1fc7a58d8202761bf1501447e48914 and keeps just the small refactoring unifying `flipSeqTake` and `flipSeqScanl'` into `flipSeq`. It also adds a new test for #23021 (which was the reason for reverting) as well as adds a clarifying comment to T18964. Fixes #23021, unfixes #18964. Metric Increase: T18964 Metric Decrease: T18964 - - - - - cf118e2f by Simon Peyton Jones at 2023-03-01T04:18:33-05:00 Refine the test for naughty record selectors The test for naughtiness in record selectors is surprisingly subtle. See the revised Note [Naughty record selectors] in GHC.Tc.TyCl.Utils. Fixes #23038. - - - - - 86f240ca by romes at 2023-03-01T04:19:10-05:00 fix: Consider strictness annotation in rep_bind Fixes #23036 - - - - - 1ed573a5 by Richard Eisenberg at 2023-03-02T22:42:06-05:00 Don't suppress *all* Wanteds Code in GHC.Tc.Errors.reportWanteds suppresses a Wanted if its rewriters have unfilled coercion holes; see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. But if we thereby suppress *all* errors that's really confusing, and as #22707 shows, GHC goes on without even realising that the program is broken. Disaster. This MR arranges to un-suppress them all if they all get suppressed. Close #22707 - - - - - 8919f341 by Luite Stegeman at 2023-03-02T22:42:45-05:00 Check for platform support for JavaScript foreign imports GHC was accepting `foreign import javascript` declarations on non-JavaScript platforms. This adds a check so that these are only supported on an platform that supports the JavaScript calling convention. Fixes #22774 - - - - - db83f8bb by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Statically assert alignment of Capability In #22965 we noticed that changes in the size of `Capability` can result in unsound behavior due to the `align` pragma claiming an alignment which we don't in practice observe. Avoid this by statically asserting that the size is a multiple of the alignment. - - - - - 5f7a4a6d by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Introduce stgMallocAlignedBytes - - - - - 8a6f745d by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Correctly align Capability allocations Previously we failed to tell the C allocator that `Capability`s needed to be aligned, resulting in #22965. Fixes #22965. Fixes #22975. - - - - - 5464c73f by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Drop no-alignment special case for Windows For reasons that aren't clear, we were previously not giving Capability the same favorable alignment on Windows that we provided on other platforms. Fix this. - - - - - a86aae8b by Matthew Pickering at 2023-03-02T22:43:59-05:00 constant folding: Correct type of decodeDouble_Int64 rule The first argument is Int64# unconditionally, so we better produce something of that type. This fixes a core lint error found in the ad package. Fixes #23019 - - - - - 68dd64ff by Zubin Duggal at 2023-03-02T22:44:35-05:00 ncg/aarch64: Handle MULTILINE_COMMENT identically as COMMENTs Commit 7566fd9de38c67360c090f828923d41587af519c with the fix for #22798 was incomplete as it failed to handle MULTILINE_COMMENT pseudo-instructions, and didn't completly fix the compiler panics when compiling with `-fregs-graph`. Fixes #23002 - - - - - 2f97c861 by Simon Peyton Jones at 2023-03-02T22:45:11-05:00 Get the right in-scope set in etaBodyForJoinPoint Fixes #23026 - - - - - 45af8482 by David Feuer at 2023-03-03T11:40:47-05:00 Export getSolo from Data.Tuple Proposed in [CLC proposal #113](https://github.com/haskell/core-libraries-committee/issues/113) and [approved by the CLC](https://github.com/haskell/core-libraries-committee/issues/113#issuecomment-1452452191) - - - - - 0c694895 by David Feuer at 2023-03-03T11:40:47-05:00 Document getSolo - - - - - bd0536af by Simon Peyton Jones at 2023-03-03T11:41:23-05:00 More fixes for `type data` declarations This MR fixes #23022 and #23023. Specifically * Beef up Note [Type data declarations] in GHC.Rename.Module, to make invariant (I1) explicit, and to name the several wrinkles. And add references to these specific wrinkles. * Add a Lint check for invariant (I1) above. See GHC.Core.Lint.checkTypeDataConOcc * Disable the `caseRules` for dataToTag# for `type data` values. See Wrinkle (W2c) in the Note above. Fixes #23023. * Refine the assertion in dataConRepArgTys, so that it does not complain about the absence of a wrapper for a `type data` constructor Fixes #23022. Acked-by: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - 858f34d5 by Oleg Grenrus at 2023-03-04T01:13:55+02:00 Add decideSymbol, decideChar, decideNat, decTypeRep, decT and hdecT These all type-level equality decision procedures. Implementes a CLC proposal https://github.com/haskell/core-libraries-committee/issues/98 - - - - - bf43ba92 by Simon Peyton Jones at 2023-03-04T01:18:23-05:00 Add test for T22793 - - - - - c6e1f3cd by Chris Wendt at 2023-03-04T03:35:18-07:00 Fix typo in docs referring to threadLabel - - - - - 232cfc24 by Simon Peyton Jones at 2023-03-05T19:57:30-05:00 Add regression test for #22328 - - - - - 5ed77deb by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Enable response files for linker if supported - - - - - 1e0f6c89 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Synchronize `configure.ac` and `distrib/configure.ac.in` - - - - - 70560952 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Fix `hadrian/bindist/config.mk.in` … as suggested by @bgamari - - - - - b042b125 by sheaf at 2023-03-06T17:06:50-05:00 Apply 1 suggestion(s) to 1 file(s) - - - - - 674b6b81 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Try to create somewhat portable `ld` command I cannot figure out a good way to generate an `ld` command that works on both Linux and macOS. Normally you'd use something like `AC_LINK_IFELSE` for this purpose (I think), but that won't let us test response file support. - - - - - 83b0177e by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Quote variables … as suggested by @bgamari - - - - - 845f404d by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Fix configure failure on alpine linux - - - - - c56a3ae6 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Small fixes to configure script - - - - - cad5c576 by Andrei Borzenkov at 2023-03-06T17:07:33-05:00 Convert diagnostics in GHC.Rename.Module to proper TcRnMessage (#20115) I've turned almost all occurrences of TcRnUnknownMessage in GHC.Rename.Module module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnIllegalInstanceHeadDecl TcRnUnexpectedStandaloneDerivingDecl TcRnUnusedVariableInRuleDecl TcRnUnexpectedStandaloneKindSig TcRnIllegalRuleLhs TcRnBadAssocRhs TcRnDuplicateRoleAnnot TcRnDuplicateKindSig TcRnIllegalDerivStrategy TcRnIllegalMultipleDerivClauses TcRnNoDerivStratSpecified TcRnStupidThetaInGadt TcRnBadImplicitSplice TcRnShadowedTyVarNameInFamResult TcRnIncorrectTyVarOnLhsOfInjCond TcRnUnknownTyVarsOnRhsOfInjCond Was introduced one helper type: RuleLhsErrReason - - - - - c6432eac by Apoorv Ingle at 2023-03-06T23:26:12+00:00 Constraint simplification loop now depends on `ExpansionFuel` instead of a boolean flag for `CDictCan.cc_pend_sc`. Pending givens get a fuel of 3 while Wanted and quantified constraints get a fuel of 1. This helps pending given constraints to keep up with pending wanted constraints in case of `UndecidableSuperClasses` and superclass expansions while simplifying the infered type. Adds 3 dynamic flags for controlling the fuels for each type of constraints `-fgivens-expansion-fuel` for givens `-fwanteds-expansion-fuel` for wanteds and `-fqcs-expansion-fuel` for quantified constraints Fixes #21909 Added Tests T21909, T21909b Added Note [Expanding Recursive Superclasses and ExpansionFuel] - - - - - a5afc8ab by Bodigrim at 2023-03-06T22:51:01-05:00 Documentation: describe laziness of several function from Data.List - - - - - fa559c28 by Ollie Charles at 2023-03-07T20:56:21+00:00 Add `Data.Functor.unzip` This function is currently present in `Data.List.NonEmpty`, but `Data.Functor` is a better home for it. This change was discussed and approved by the CLC at https://github.com/haskell/core-libraries-committee/issues/88. - - - - - 2aa07708 by MorrowM at 2023-03-07T21:22:22-05:00 Fix documentation for traceWith and friends - - - - - f3ff7cb1 by David Binder at 2023-03-08T01:24:17-05:00 Remove utils/hpc subdirectory and its contents - - - - - cf98e286 by David Binder at 2023-03-08T01:24:17-05:00 Add git submodule for utils/hpc - - - - - 605fbbb2 by David Binder at 2023-03-08T01:24:18-05:00 Update commit for utils/hpc git submodule - - - - - 606793d4 by David Binder at 2023-03-08T01:24:18-05:00 Update commit for utils/hpc git submodule - - - - - 4158722a by Sylvain Henry at 2023-03-08T01:24:58-05:00 linker: fix linking with aligned sections (#23066) Take section alignment into account instead of assuming 16 bytes (which is wrong when the section requires 32 bytes, cf #23066). - - - - - 1e0d8fdb by Greg Steuck at 2023-03-08T08:59:05-05:00 Change hostSupportsRPaths to report False on OpenBSD OpenBSD does support -rpath but ghc build process relies on some related features that don't work there. See ghc/ghc#23011 - - - - - bed3a292 by Alexis King at 2023-03-08T08:59:53-05:00 bytecode: Fix bitmaps for BCOs used to tag tuples and prim call args fixes #23068 - - - - - 321d46d9 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Drop redundant prototype - - - - - abb6070f by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix style - - - - - be278901 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Deduplicate assertion - - - - - b9034639 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Fix type issues in Sparks.h Adds explicit casts to satisfy a C++ compiler. - - - - - da7b2b94 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Use release ordering when storing thread labels Since this makes the ByteArray# visible from other cores. - - - - - 5b7f6576 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/BlockAlloc: Allow disabling of internal assertions These can be quite expensive and it is sometimes useful to compile a DEBUG RTS without them. - - - - - 6283144f by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/Sanity: Mark pinned_object_blocks - - - - - 9b528404 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/Sanity: Look at nonmoving saved_filled lists - - - - - 0edc5438 by Ben Gamari at 2023-03-08T15:02:30-05:00 Evac: Squash data race in eval_selector_chain - - - - - 7eab831a by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Clarify implementation This makes the intent of this implementation a bit clearer. - - - - - 532262b9 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Clarify comment - - - - - bd9cd84b by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Add missing no-op in busy-wait loop - - - - - c4e6bfc8 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't push empty arrays to update remembered set Previously the write barrier of resizeSmallArray# incorrectly handled resizing of zero-sized arrays, pushing an invalid pointer to the update remembered set. Fixes #22931. - - - - - 92227b60 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix handling of weak pointers This fixes an interaction between aging and weak pointer handling which prevented the finalization of some weak pointers. In particular, weak pointers could have their keys incorrectly marked by the preparatory collector, preventing their finalization by the subsequent concurrent collection. While in the area, we also significantly improve the assertions regarding weak pointers. Fixes #22327. - - - - - ba7e7972 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Sanity check nonmoving large objects and compacts - - - - - 71b038a1 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Sanity check mutable list Assert that entries in the nonmoving generation's generational remembered set (a.k.a. mutable list) live in nonmoving generation. - - - - - 99d144d5 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't show occupancy if we didn't collect live words - - - - - 81d6cc55 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix tracking of FILLED_SWEEPING segments Previously we only updated the state of the segment at the head of each allocator's filled list. - - - - - 58e53bc4 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Assert state of swept segments - - - - - 2db92e01 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Handle new closures in nonmovingIsNowAlive We must conservatively assume that new closures are reachable since we are not guaranteed to mark such blocks. - - - - - e4c3249f by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't clobber update rem sets of old capabilities Previously `storageAddCapabilities` (called by `setNumCapabilities`) would clobber the update remembered sets of existing capabilities when increasing the capability count. Fix this by only initializing the update remembered sets of the newly-created capabilities. Fixes #22927. - - - - - 1b069671 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Add missing write barriers in selector optimisation This fixes the selector optimisation, adding a few write barriers which are necessary for soundness. See the inline comments for details. Fixes #22930. - - - - - d4032690 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Post-sweep sanity checking - - - - - 0baa8752 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Avoid n_caps race - - - - - 5d3232ba by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Don't push if nonmoving collector isn't enabled - - - - - 0a7eb0aa by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Be more paranoid in segment tracking Previously we left various segment link pointers dangling. None of this wrong per se, but it did make it harder than necessary to debug. - - - - - 7c817c0a by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Sync-phase mark budgeting Here we significantly improve the bound on sync phase pause times by imposing a limit on the amount of work that we can perform during the sync. If we find that we have exceeded our marking budget then we allow the mutators to resume, return to concurrent marking, and try synchronizing again later. Fixes #22929. - - - - - ce22a3e2 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Allow pinned gen0 objects to be WEAK keys - - - - - 78746906 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Reenable assertion - - - - - b500867a by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Move current segment array into Capability The current segments are conceptually owned by the mutator, not the collector. Consequently, it was quite tricky to prove that the mutator would not race with the collect due to this shared state. It turns out that such races are possible: when resizing the current segment array we may concurrently try to take a heap census. This will attempt to walk the current segment array, causing a data race. Fix this by moving the current segment array into `Capability`, where it belongs. Fixes #22926. - - - - - 56e669c1 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Fix Note references Some references to Note [Deadlock detection under the non-moving collector] were missing an article. - - - - - 4a7650d7 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts/Sanity: Fix block count assertion with non-moving collector The nonmoving collector does not use `oldest_gen->blocks` to track its block list. However, it nevertheless updates `oldest_gen->n_blocks` to ensure that its size is accounted for by the storage manager. Consequently, we must not attempt to assert consistency between the two. - - - - - 96a5aaed by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Don't call prepareUnloadCheck When the nonmoving GC is in use we do not call `checkUnload` (since we don't unload code) and therefore should not call `prepareUnloadCheck`, lest we run into assertions. - - - - - 6c6674ca by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Encapsulate block allocator spinlock This makes it a bit easier to add instrumentation on this spinlock while debugging. - - - - - e84f7167 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Skip some tests when sanity checking is enabled - - - - - 3ae0f368 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Fix unregisterised build - - - - - 4eb9d06b by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Ensure that sanity checker accounts for saved_filled segments - - - - - f0cf384d by Ben Gamari at 2023-03-08T15:02:31-05:00 hadrian: Add +boot_nonmoving_gc flavour transformer For using GHC bootstrapping to validate the non-moving GC. - - - - - 581e58ac by Ben Gamari at 2023-03-08T15:02:31-05:00 gitlab-ci: Add job bootstrapping with nonmoving GC - - - - - 487a8b58 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Move allocator into new source file - - - - - 8f374139 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Split out nonmovingAllocateGC - - - - - 662b6166 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Only run T22795* in the normal way It doesn't make sense to run these in multiple ways as they merely test whether `-threaded`/`-single-threaded` flags. - - - - - 0af21dfa by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Rename clear_segment(_free_blocks)? To reflect the fact that these are to do with the nonmoving collector, now since they are exposed no longer static. - - - - - 7bcb192b by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Fix incorrect STATIC_INLINE This should be INLINE_HEADER lest we get unused declaration warnings. - - - - - f1fd3ffb by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Mark ffi023 as broken due to #23089 - - - - - a57f12b3 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Skip T7160 in the nonmoving way Finalization order is different under the nonmoving collector. - - - - - f6f12a36 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Capture GC configuration in a struct The number of distinct arguments passed to GarbageCollect was getting a bit out of hand. - - - - - ba73a807 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Non-concurrent collection - - - - - 7c813d06 by Alexis King at 2023-03-08T15:03:10-05:00 hadrian: Fix flavour compiler stage options off-by-one error !9193 pointed out that ghcDebugAssertions was supposed to be a predicate on the stage of the built compiler, but in practice it was a predicate on the stage of the compiler used to build. Unfortunately, while it fixed that issue for ghcDebugAssertions, it documented every other similar option as behaving the same way when in fact they all used the old behavior. The new behavior of ghcDebugAssertions seems more intuitive, so this commit changes the interpretation of every other option to match. It also improves the enableProfiledGhc and debugGhc flavour transformers by making them more selective about which stages in which they build additional library/RTS ways. - - - - - f97c7f6d by Luite Stegeman at 2023-03-09T09:52:09-05:00 Delete created temporary subdirectories at end of session. This patch adds temporary subdirectories to the list of paths do clean up at the end of the GHC session. This fixes warnings about non-empty temporary directories. Fixes #22952 - - - - - 9ea719f2 by Apoorv Ingle at 2023-03-09T09:52:45-05:00 Fixes #19627. Previously the solver failed with an unhelpful "solver reached too may iterations" error. With the fix for #21909 in place we no longer have the possibility of generating such an error if we have `-fconstraint-solver-iteration` > `-fgivens-fuel > `-fwanteds-fuel`. This is true by default, and the said fix also gives programmers a knob to control how hard the solver should try before giving up. This commit adds: * Reference to ticket #19627 in the Note [Expanding Recursive Superclasses and ExpansionFuel] * Test `typecheck/should_fail/T19627.hs` for regression purposes - - - - - ec2d93eb by Sebastian Graf at 2023-03-10T10:18:54-05:00 DmdAnal: Fix a panic on OPAQUE and trivial/PAP RHS (#22997) We should not panic in `add_demands` (now `set_lam_dmds`), because that code path is legimitely taken for OPAQUE PAP bindings, as in T22997. Fixes #22997. - - - - - 5b4628ae by Sylvain Henry at 2023-03-10T10:19:34-05:00 JS: remove dead code for old integer-gmp - - - - - bab23279 by Josh Meredith at 2023-03-10T23:24:49-05:00 JS: Fix implementation of MK_JSVAL - - - - - ec263a59 by Sebastian Graf at 2023-03-10T23:25:25-05:00 Simplify: Move `wantEtaExpansion` before expensive `do_eta_expand` check There is no need to run arity analysis and what not if we are not in a Simplifier phase that eta-expands or if we don't want to eta-expand the expression in the first place. Purely a refactoring with the goal of improving compiler perf. - - - - - 047e9d4f by Josh Meredith at 2023-03-13T03:56:03+00:00 JS: fix implementation of forceBool to use JS backend syntax - - - - - 559a4804 by Sebastian Graf at 2023-03-13T07:31:23-04:00 Simplifier: `countValArgs` should not count Type args (#23102) I observed miscompilations while working on !10088 caused by this. Fixes #23102. Metric Decrease: T10421 - - - - - 536d1f90 by Matthew Pickering at 2023-03-13T14:04:49+00:00 Bump Win32 to 2.13.4.0 Updates Win32 submodule - - - - - ee17001e by Ben Gamari at 2023-03-13T21:18:24-04:00 ghc-bignum: Drop redundant include-dirs field - - - - - c9c26cd6 by Teo Camarasu at 2023-03-16T12:17:50-04:00 Fix BCO creation setting caps when -j > -N * Remove calls to 'setNumCapabilities' in 'createBCOs' These calls exist to ensure that 'createBCOs' can benefit from parallelism. But this is not the right place to call `setNumCapabilities`. Furthermore the logic differs from that in the driver causing the capability count to be raised and lowered at each TH call if -j > -N. * Remove 'BCOOpts' No longer needed as it was only used to thread the job count down to `createBCOs` Resolves #23049 - - - - - 5ddbf5ed by Teo Camarasu at 2023-03-16T12:17:50-04:00 Add changelog entry for #23049 - - - - - 6e3ce9a4 by Ben Gamari at 2023-03-16T12:18:26-04:00 configure: Fix FIND_CXX_STD_LIB test on Darwin Annoyingly, Darwin's <cstddef> includes <version> and APFS is case-insensitive. Consequently, it will end up #including the `VERSION` file generated by the `configure` script on the second and subsequent runs of the `configure` script. See #23116. - - - - - 19d6d039 by sheaf at 2023-03-16T21:31:22+01:00 ghci: only keep the GlobalRdrEnv in ModInfo The datatype GHC.UI.Info.ModInfo used to store a ModuleInfo, which includes a TypeEnv. This can easily cause space leaks as we have no way of forcing everything in a type environment. In GHC, we only use the GlobalRdrEnv, which we can force completely. So we only store that instead of a fully-fledged ModuleInfo. - - - - - 73d07c6e by Torsten Schmits at 2023-03-17T14:36:49-04:00 Add structured error messages for GHC.Tc.Utils.Backpack Tracking ticket: #20119 MR: !10127 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. One occurrence, when handing a nested error from the interface loading machinery, was omitted. It will be handled by a subsequent changeset that addresses interface errors. - - - - - a13affce by Andrei Borzenkov at 2023-03-21T11:17:17-04:00 Rename () into Unit, (,,...,,) into Tuple<n> (#21294) This patch implements a part of GHC Proposal #475. The key change is in GHC.Tuple.Prim: - data () = () - data (a,b) = (a,b) - data (a,b,c) = (a,b,c) ... + data Unit = () + data Tuple2 a b = (a,b) + data Tuple3 a b c = (a,b,c) ... And the rest of the patch makes sure that Unit and Tuple<n> are pretty-printed as () and (,,...,,) in various contexts. Updates the haddock submodule. Co-authored-by: Vladislav Zavialov <vlad.z.4096 at gmail.com> - - - - - 23642bf6 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: fix some wrongs in the eventlog format documentation - - - - - 90159773 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: explain the BLOCK_MARKER event - - - - - ab1c25e8 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add BlockedOnMVarRead thread status in eventlog encodings - - - - - 898afaef by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add TASK_DELETE event in eventlog encodings - - - - - bb05b4cc by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add WALL_CLOCK_TIME event in eventlog encodings - - - - - eeea0343 by Torsten Schmits at 2023-03-21T11:18:34-04:00 Add structured error messages for GHC.Tc.Utils.Env Tracking ticket: #20119 MR: !10129 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - be1d4be8 by Bodigrim at 2023-03-21T11:19:13-04:00 Document pdep / pext primops - - - - - e8b4aac4 by Alex Mason at 2023-03-21T18:11:04-04:00 Allow LLVM backend to use HDoc for faster file generation. Also remove the MetaStmt constructor from LlvmStatement and places the annotations into the Store statement. Includes “Implement a workaround for -no-asm-shortcutting bug“ (https://gitlab.haskell.org/ghc/ghc/-/commit/2fda9e0df886cc551e2cd6b9c2a384192bdc3045) - - - - - ea24360d by Luite Stegeman at 2023-03-21T18:11:44-04:00 Compute LambdaFormInfo when using JavaScript backend. CmmCgInfos is needed to write interface files, but the JavaScript backend does not generate it, causing "Name without LFInfo" warnings. This patch adds a conservative but always correct CmmCgInfos when the JavaScript backend is used. Fixes #23053 - - - - - 926ad6de by Simon Peyton Jones at 2023-03-22T01:03:08-04:00 Be more careful about quantification This MR is driven by #23051. It does several things: * It is guided by the generalisation plan described in #20686. But it is still far from a complete implementation of that plan. * Add Note [Inferred type with escaping kind] to GHC.Tc.Gen.Bind. This explains that we don't (yet, pending #20686) directly prevent generalising over escaping kinds. * In `GHC.Tc.Utils.TcMType.defaultTyVar` we default RuntimeRep and Multiplicity variables, beause we don't want to quantify over them. We want to do the same for a Concrete tyvar, but there is nothing sensible to default it to (unless it has kind RuntimeRep, in which case it'll be caught by an earlier case). So we promote instead. * Pure refactoring in GHC.Tc.Solver: * Rename decideMonoTyVars to decidePromotedTyVars, since that's what it does. * Move the actual promotion of the tyvars-to-promote from `defaultTyVarsAndSimplify` to `decidePromotedTyVars`. This is a no-op; just tidies up the code. E.g then we don't need to return the promoted tyvars from `decidePromotedTyVars`. * A little refactoring in `defaultTyVarsAndSimplify`, but no change in behaviour. * When making a TauTv unification variable into a ConcreteTv (in GHC.Tc.Utils.Concrete.makeTypeConcrete), preserve the occ-name of the type variable. This just improves error messages. * Kill off dead code: GHC.Tc.Utils.TcMType.newConcreteHole - - - - - 0ab0cc11 by Sylvain Henry at 2023-03-22T01:03:48-04:00 Testsuite: use appropriate predicate for ManyUbxSums test (#22576) - - - - - 048c881e by romes at 2023-03-22T01:04:24-04:00 fix: Incorrect @since annotations in GHC.TypeError Fixes #23128 - - - - - a1528b68 by Sylvain Henry at 2023-03-22T01:05:04-04:00 Testsuite: use req_interp predicate for T16318 (#22370) - - - - - ad765b6f by Sylvain Henry at 2023-03-22T01:05:04-04:00 Testsuite: use req_interp predicate for T20214 - - - - - e0b8eaf3 by Simon Peyton Jones at 2023-03-22T09:50:13+00:00 Refactor the constraint solver pipeline The big change is to put the entire type-equality solver into GHC.Tc.Solver.Equality, rather than scattering it over Canonical and Interact. Other changes * EqCt becomes its own data type, a bit like QCInst. This is great because EqualCtList is then just [EqCt] * New module GHC.Tc.Solver.Dict has come of the class-contraint solver. In due course it will be all. One step at a time. This MR is intended to have zero change in behaviour: it is a pure refactor. It opens the way to subsequent tidying up, we believe. - - - - - cedf9a3b by Torsten Schmits at 2023-03-22T15:31:18-04:00 Add structured error messages for GHC.Tc.Utils.TcMType Tracking ticket: #20119 MR: !10138 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 30d45e97 by Sylvain Henry at 2023-03-22T15:32:01-04:00 Testsuite: use js_skip for T2615 (#22374) - - - - - 8c98deba by Armando Ramirez at 2023-03-23T09:19:32-04:00 Optimized Foldable methods for Data.Functor.Compose Explicitly define length, elem, etc. in Foldable instance for Data.Functor.Compose Implementation of https://github.com/haskell/core-libraries-committee/issues/57 - - - - - bc066108 by Armando Ramirez at 2023-03-23T09:19:32-04:00 Additional optimized versions - - - - - 80fce576 by Bodigrim at 2023-03-23T09:19:32-04:00 Simplify minimum/maximum in instance Foldable (Compose f g) - - - - - 8cb88a5a by Bodigrim at 2023-03-23T09:19:32-04:00 Update changelog to mention changes to instance Foldable (Compose f g) - - - - - e1c8c41d by Torsten Schmits at 2023-03-23T09:20:13-04:00 Add structured error messages for GHC.Tc.TyCl.PatSyn Tracking ticket: #20117 MR: !10158 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - f932c589 by Adam Gundry at 2023-03-24T02:36:09-04:00 Allow WARNING pragmas to be controlled with custom categories Closes #17209. This implements GHC Proposal 541, allowing a WARNING pragma to be annotated with a category like so: {-# WARNING in "x-partial" head "This function is undefined on empty lists." #-} The user can then enable, disable and set the severity of such warnings using command-line flags `-Wx-partial`, `-Werror=x-partial` and so on. There is a new warning group `-Wextended-warnings` containing all these warnings. Warnings without a category are treated as if the category was `deprecations`, and are (still) controlled by the flags `-Wdeprecations` and `-Wwarnings-deprecations`. Updates Haddock submodule. - - - - - 0426515b by Adam Gundry at 2023-03-24T02:36:09-04:00 Move mention of warning groups change to 9.8.1 release notes - - - - - b8d783d2 by Ben Gamari at 2023-03-24T02:36:45-04:00 nativeGen/AArch64: Fix bitmask immediate predicate Previously the predicate for determining whether a logical instruction operand could be encoded as a bitmask immediate was far too conservative. This meant that, e.g., pointer untagged required five instructions whereas it should only require one. Fixes #23030. - - - - - 46120bb6 by Joachim Breitner at 2023-03-24T13:09:43-04:00 User's guide: Improve docs for -Wall previously it would list the warnings _not_ enabled by -Wall. That’s unnecessary round-about and was out of date. So let's just name the relevant warnings (based on `compiler/GHC/Driver/Flags.hs`). - - - - - 509d1f11 by Ben Gamari at 2023-03-24T13:10:20-04:00 codeGen/tsan: Disable instrumentation of unaligned stores There is some disagreement regarding the prototype of `__tsan_unaligned_write` (specifically whether it takes just the written address, or the address and the value as an argument). Moreover, I have observed crashes which appear to be due to it. Disable instrumentation of unaligned stores as a temporary mitigation. Fixes #23096. - - - - - 6a73655f by Li-yao Xia at 2023-03-25T00:02:44-04:00 base: Document GHC versions associated with past base versions in the changelog - - - - - 43bd7694 by Teo Camarasu at 2023-03-25T00:03:24-04:00 Add regression test for #17574 This test currently fails in the nonmoving way - - - - - f2d56bf7 by Teo Camarasu at 2023-03-25T00:03:24-04:00 fix: account for large and compact object stats with nonmoving gc Make sure that we keep track of the size of large and compact objects that have been moved onto the nonmoving heap. We keep track of their size and add it to the amount of live bytes in nonmoving segments to get the total size of the live nonmoving heap. Resolves #17574 - - - - - 7131b705 by David Feuer at 2023-03-25T00:04:04-04:00 Modify ThreadId documentation and comments For a long time, `GHC.Conc.Sync` has said ```haskell -- ToDo: data ThreadId = ThreadId (Weak ThreadId#) -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. ``` We are now actually capable of using `Weak# ThreadId#`, but the world has moved on. To support the `Show` and `Ord` instances, we'd need to store the thread ID number in the `ThreadId`. And it seems very difficult to continue to support `threadStatus` in that regime, since it needs to be able to explain how threads died. In addition, garbage collection of weak references can be quite expensive, and it would be hard to evaluate the cost over he whole ecosystem. As discussed in [this CLC issue](https://github.com/haskell/core-libraries-committee/issues/125), it doesn't seem very likely that we'll actually switch to weak references here. - - - - - c421bbbb by Ben Gamari at 2023-03-25T00:04:41-04:00 rts: Fix barriers of IND and IND_STATIC Previously IND and IND_STATIC lacked the acquire barriers enjoyed by BLACKHOLE. As noted in the (now updated) Note [Heap memory barriers], this barrier is critical to ensure that the indirectee is visible to the entering core. Fixes #22872. - - - - - 62fa7faa by Bodigrim at 2023-03-25T00:05:22-04:00 Improve documentation of atomicModifyMutVar2# - - - - - b2d14d0b by Cheng Shao at 2023-03-25T03:46:43-04:00 rts: use performBlockingMajorGC in hs_perform_gc and fix ffi023 This patch does a few things: - Add the missing RtsSymbols.c entry of performBlockingMajorGC - Make hs_perform_gc call performBlockingMajorGC, which restores previous behavior - Use hs_perform_gc in ffi023 - Remove rts_clearMemory() call in ffi023, it now works again in some test ways previously marked as broken. Fixes #23089 - - - - - d9ae24ad by Cheng Shao at 2023-03-25T03:46:44-04:00 testsuite: add the rts_clearMemory test case This patch adds a standalone test case for rts_clearMemory that mimics how it's typically used by wasm backend users and ensures this RTS API isn't broken by future RTS refactorings. Fixes #23901. - - - - - 80729d96 by Bodigrim at 2023-03-25T03:47:22-04:00 Improve documentation for resizing of byte arrays - - - - - c6ec4cd1 by Ben Gamari at 2023-03-25T20:23:47-04:00 rts: Don't rely on EXTERN_INLINE for slop-zeroing logic Previously we relied on calling EXTERN_INLINE functions defined in ClosureMacros.h from Cmm to zero slop. However, as far as I can tell, this is no longer safe to do in C99 as EXTERN_INLINE definitions may be emitted in each compilation unit. Fix this by explicitly declaring a new set of non-inline functions in ZeroSlop.c which can be called from Cmm and marking the ClosureMacros.h definitions as INLINE_HEADER. In the future we should try to eliminate EXTERN_INLINE. - - - - - c32abd4b by Ben Gamari at 2023-03-25T20:23:48-04:00 rts: Fix capability-count check in zeroSlop Previously `zeroSlop` examined `RtsFlags` to determine whether the program was single-threaded. This is wrong; a program may be started with `+RTS -N1` yet the process may later increase the capability count with `setNumCapabilities`. This lead to quite subtle and rare crashes. Fixes #23088. - - - - - 656d4cb3 by Ryan Scott at 2023-03-25T20:24:23-04:00 Add Eq/Ord instances for SSymbol, SChar, and SNat This implements [CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148). - - - - - 4f93de88 by David Feuer at 2023-03-26T15:33:02-04:00 Update and expand atomic modification Haddocks * The documentation for `atomicModifyIORef` and `atomicModifyIORef'` were incomplete, and the documentation for `atomicModifyIORef` was out of date. Update and expand. * Remove a useless lazy pattern match in the definition of `atomicModifyIORef`. The pair it claims to match lazily was already forced by `atomicModifyIORef2`. - - - - - e1fb56b2 by David Feuer at 2023-03-26T15:33:41-04:00 Document the constructor name for lists Derived `Data` instances use raw infix constructor names when applicable. The `Data.Data [a]` instance, if derived, would have a constructor name of `":"`. However, it actually uses constructor name `"(:)"`. Document this peculiarity. See https://github.com/haskell/core-libraries-committee/issues/147 - - - - - c1f755c4 by Simon Peyton Jones at 2023-03-27T22:09:41+01:00 Make exprIsConApp_maybe a bit cleverer Addresses #23159. See Note Note [Exploit occ-info in exprIsConApp_maybe] in GHC.Core.SimpleOpt. Compile times go down very slightly, but always go down, never up. Good! Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -1.8% T15703(normal) -1.2% GOOD geo. mean -0.1% minimum -1.8% maximum +0.0% Metric Decrease: CoOpt_Singletons T15703 - - - - - 76bb4c58 by Ryan Scott at 2023-03-28T08:12:08-04:00 Add COMPLETE pragmas to TypeRep, SSymbol, SChar, and SNat This implements [CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149). - - - - - 3f374399 by sheaf at 2023-03-29T13:57:33+02:00 Handle records in the renamer This patch moves the field-based logic for disambiguating record updates to the renamer. The type-directed logic, scheduled for removal, remains in the typechecker. To do this properly (and fix the myriad of bugs surrounding the treatment of duplicate record fields), we took the following main steps: 1. Create GREInfo, a renamer-level equivalent to TyThing which stores information pertinent to the renamer. This allows us to uniformly treat imported and local Names in the renamer, as described in Note [GREInfo]. 2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which distinguished between normal names and field names, we now store simple Names in GlobalRdrElt, along with the new GREInfo information which allows us to recover the FieldLabel for record fields. 3. Add namespacing for record fields, within the OccNames themselves. This allows us to remove the mangling of duplicate field selectors. This change ensures we don't print mangled names to the user in error messages, and allows us to handle duplicate record fields in Template Haskell. 4. Move record disambiguation to the renamer, and operate on the level of data constructors instead, to handle #21443. The error message text for ambiguous record updates has also been changed to reflect that type-directed disambiguation is on the way out. (3) means that OccEnv is now a bit more complex: we first key on the textual name, which gives an inner map keyed on NameSpace: OccEnv a ~ FastStringEnv (UniqFM NameSpace a) Note that this change, along with (2), both increase the memory residency of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to regress somewhat in compile-time allocation. Even though (3) simplified a lot of code (in particular the treatment of field selectors within Template Haskell and in error messages), it came with one important wrinkle: in the situation of -- M.hs-boot module M where { data A; foo :: A -> Int } -- M.hs module M where { data A = MkA { foo :: Int } } we have that M.hs-boot exports a variable foo, which is supposed to match with the record field foo that M exports. To solve this issue, we add a new impedance-matching binding to M foo{var} = foo{fld} This mimics the logic that existed already for impedance-binding DFunIds, but getting it right was a bit tricky. See Note [Record field impedance matching] in GHC.Tc.Module. We also needed to be careful to avoid introducing space leaks in GHCi. So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in ModIface. This means stubbing out all the GREInfo fields, with the function forceGlobalRdrEnv. When we read it back in, we rehydrate with rehydrateGlobalRdrEnv. This robustly avoids any space leaks caused by retaining old type environments. Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063 Updates haddock submodule ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiLayerModulesDefsGhci MultiLayerModulesNoCode T13701 T14697 hard_hole_fits ------------------------- - - - - - 4f1940f0 by sheaf at 2023-03-29T13:57:33+02:00 Avoid repeatedly shadowing in shadowNames This commit refactors GHC.Type.Name.Reader.shadowNames to first accumulate all the shadowing arising from the introduction of a new set of GREs, and then applies all the shadowing to the old GlobalRdrEnv in one go. - - - - - d246049c by sheaf at 2023-03-29T13:57:34+02:00 igre_prompt_env: discard "only-qualified" names We were unnecessarily carrying around names only available qualified in igre_prompt_env, violating the icReaderEnv invariant. We now get rid of these, as they aren't needed for the shadowing computation that igre_prompt_env exists for. Fixes #23177 ------------------------- Metric Decrease: T14052 T14052Type ------------------------- - - - - - 41a572f6 by Matthew Pickering at 2023-03-29T16:17:21-04:00 hadrian: Fix path to HpcParser.y The source for this project has been moved into a src/ folder so we also need to update this path. Fixes #23187 - - - - - b159e0e9 by doyougnu at 2023-03-30T01:40:08-04:00 js: split JMacro into JS eDSL and JS syntax This commit: Splits JExpr and JStat into two nearly identical DSLs: - GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a value cannot be unsaturated, or, a value of this DSL is a witness that a value of GHC.JS.Unsat has been saturated - GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation. Then all binary and outputable instances are changed to use GHC.JS.Syntax. This moves us closer to closing out #22736 and #22352. See #22736 for roadmap. ------------------------- Metric Increase: CoOpt_Read LargeRecord ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T10858 T11195 T11374 T11822 T12227 T12707 T13035 T13253 T13253-spj T13379 T14683 T15164 T15703 T16577 T17096 T17516 T17836 T18140 T18282 T18304 T18478 T18698a T18698b T18923 T1969 T19695 T20049 T21839c T3064 T4801 T5321FD T5321Fun T5631 T5642 T783 T9198 T9233 T9630 TcPlugin_RewritePerf WWRec ------------------------- - - - - - f4f1f14f by Sylvain Henry at 2023-03-30T01:40:49-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. Also used the opportunity to reenable 64-bit Word/Int tests - - - - - a5360490 by Ben Gamari at 2023-03-30T01:41:25-04:00 testsuite: Fix racing prints in T21465 As noted in #23155, we previously failed to add flushes necessary to ensure predictable output. Fixes #23155. - - - - - 98b5cf67 by Matthew Pickering at 2023-03-30T09:58:40+01:00 Revert "ghc-heap: remove wrong Addr# coercion (#23181)" This reverts commit f4f1f14f8009c3c120b8b963ec130cbbc774ec02. This fails to build with GHC-9.2 as a boot compiler. See #23195 for tracking this issue. - - - - - 61a2dfaa by Bodigrim at 2023-03-30T14:35:57-04:00 Add {-# WARNING #-} to Data.List.{head,tail} - - - - - 8f15c47c by Bodigrim at 2023-03-30T14:35:57-04:00 Fixes to accomodate Data.List.{head,tail} with {-# WARNING #-} - - - - - 7c7dbade by Bodigrim at 2023-03-30T14:35:57-04:00 Bump submodules - - - - - d2d8251b by Bodigrim at 2023-03-30T14:35:57-04:00 Fix tests - - - - - 3d38dcb6 by sheaf at 2023-03-30T14:35:57-04:00 Proxies for head and tail: review suggestions - - - - - 930edcfd by sheaf at 2023-03-30T14:36:33-04:00 docs: move RecordUpd changelog entry to 9.8 This was accidentally included in the 9.6 changelog instead of the 9.6 changelog. - - - - - 6f885e65 by sheaf at 2023-03-30T14:37:09-04:00 Add LANGUAGE GADTs to GHC.Rename.Env We need to enable this extension for the file to compile with ghc 9.2, as we are pattern matching on a GADT and this required the GADT extension to be enabled until 9.4. - - - - - 6d6a37a8 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: make lint-ci-config job fast again We don't pin our nixpkgs revision and tracks the default nixpkgs-unstable channel anyway. Instead of using haskell.packages.ghc924, we should be using haskell.packages.ghc92 to maximize the binary cache hit rate and make lint-ci-config job fast again. Also bumps the nix docker image to the latest revision. - - - - - ef1548c4 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: ensure that all non-i386 pipelines do parallel xz compression We can safely enable parallel xz compression for non-i386 pipelines. However, previously we didn't export XZ_OPT, so the xz process won't see it if XZ_OPT hasn't already been set in the current job. - - - - - 20432d16 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: unset CROSS_EMULATOR for js job - - - - - 4a24dbbe by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: fix lint-testsuite job The list_broken make target will transitively depend on the calibrate.out target, which used STAGE1_GHC instead of TEST_HC. It really should be TEST_HC since that's what get passed in the gitlab CI config. - - - - - cea56ccc by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: use alpine3_17-wasm image for wasm jobs Bump the ci-images dependency and use the new alpine3_17-wasm docker image for wasm jobs. - - - - - 79d0cb32 by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - e7392b4e by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Normalize away differences in ghc executable name - - - - - ee160d06 by Ben Gamari at 2023-03-30T18:43:53+00:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - 30c84511 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: don't add optllvm way for wasm32 - - - - - f1beee36 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: normalize the .wasm extension - - - - - a984a103 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: strip the cross ghc prefix in output and error message - - - - - f7478d95 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: handle target executable extension - - - - - 8fe8b653 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: mypy typing error fixes This patch fixes some mypy typing errors which weren't caught in previous linting jobs. - - - - - 0149f32f by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: use context variable instead of thread-local variable This patch changes a thread-local variable to context variable instead, which works as intended when the testsuite transitions to use asyncio & coroutines instead of multi-threading to concurrently run test cases. Note that this also raises the minimum Python version to 3.7. - - - - - ea853ff0 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: asyncify the testsuite driver This patch refactors the testsuite driver, gets rid of multi-threading logic for running test cases concurrently, and uses asyncio & coroutines instead. This is not yak shaving for its own sake; the previous multi-threading logic is prone to livelock/deadlock conditions for some reason, even if the total number of threads is bounded to a thread pool's capacity. The asyncify change is an internal implementation detail of the testsuite driver and does not impact most GHC maintainers out there. The patch does not touch the .T files, test cases can be added/modified the exact same way as before. - - - - - 0077cb22 by Matthew Pickering at 2023-03-31T21:28:28-04:00 Add test for T23184 There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj at microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 A bunch of changes related to eta reduction This is a large collection of changes all relating to eta reduction, originally triggered by #18993, but there followed a long saga. Specifics: ...lots of lines omitted... Other incidental changes * Fix a fairly long-standing outright bug in the ApplyToVal case of GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the tail of 'dmds' in the recursive call, which meant the demands were All Wrong. I have no idea why this has not caused problems before now. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes. - - - - - 62d25071 by mangoiv at 2023-04-01T04:20:01-04:00 [feat] make ($) representation polymorphic - this change was approved by the CLC in [1] following a CLC proposal [2] - make ($) representation polymorphic (adjust the type signature) - change ($) implementation to allow additional polymorphism - adjust the haddock of ($) to reflect these changes - add additional documentation to document these changes - add changelog entry - adjust tests (move now succeeding tests and adjust stdout of some tests) [1] https://github.com/haskell/core-libraries-committee/issues/132#issuecomment-1487456854 [2] https://github.com/haskell/core-libraries-committee/issues/132 - - - - - 77c33fb9 by Artem Pelenitsyn at 2023-04-01T04:20:41-04:00 User Guide: update copyright year: 2020->2023 - - - - - 3b5be05a by doyougnu at 2023-04-01T09:42:31-04:00 driver: Unit State Data.Map -> GHC.Unique.UniqMap In pursuit of #22426. The driver and unit state are major contributors. This commit also bumps the haddock submodule to reflect the API changes in UniqMap. ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp T10421 T10547 T12150 T12234 T12425 T13035 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T5837 T6048 T9198 ------------------------- - - - - - a84fba6e by Torsten Schmits at 2023-04-01T09:43:12-04:00 Add structured error messages for GHC.Tc.TyCl Tracking ticket: #20117 MR: !10183 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 6e2eb275 by doyougnu at 2023-04-01T18:27:56-04:00 JS: Linker: use saturated JExpr Follow on to MR!10142 in pursuit of #22736 - - - - - 3da69346 by sheaf at 2023-04-01T18:28:37-04:00 Improve haddocks of template-haskell Con datatype This adds a bit more information, in particular about the lists of constructors in the GadtC and RecGadtC cases. - - - - - 3b7bbb39 by sheaf at 2023-04-01T18:28:37-04:00 TH: revert changes to GadtC & RecGadtC Commit 3f374399 included a breaking-change to the template-haskell library when it made the GadtC and RecGadtC constructors take non-empty lists of names. As this has the potential to break many users' packages, we decided to revert these changes for now. - - - - - f60f6110 by Bodigrim at 2023-04-02T18:59:30-04:00 Rework documentation for data Char - - - - - 43ebd5dc by Bodigrim at 2023-04-02T19:00:09-04:00 cmm: implement parsing of MO_AtomicRMW from hand-written CMM files Fixes #23206 - - - - - ab9cd52d by Sylvain Henry at 2023-04-03T08:15:21-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. - - - - - 2b2afff3 by Matthew Pickering at 2023-04-03T08:15:58-04:00 hadrian: Update bootstrap plans for 9.2.6, 9.2.7, 9.4.4, 9.4.5, 9.6.1 Also fixes the ./generate_bootstrap_plans script which was recently broken We can hopefully drop the 9.2 plans soon but they still work so kept them around for now. - - - - - c2605e25 by Matthew Pickering at 2023-04-03T08:15:58-04:00 ci: Add job to test 9.6 bootstrapping - - - - - 53e4d513 by Krzysztof Gogolewski at 2023-04-03T08:16:35-04:00 hadrian: Improve option parsing Several options in Hadrian had their argument marked as optional (`OptArg`), but if the argument wasn't there they were just giving an error. It's more idiomatic to mark the argument as required instead; the code uses less Maybes, the parser can enforce that the argument is present, --help gives better output. - - - - - a8e36892 by Sylvain Henry at 2023-04-03T08:17:16-04:00 JS: fix issues with FD api support - Add missing implementations for fcntl_read/write/lock - Fix fdGetMode These were found while implementing TH in !9779. These functions must be used somehow by the external interpreter code. - - - - - 8b092910 by Haskell-mouse at 2023-04-03T19:31:26-04:00 Convert diagnostics in GHC.Rename.HsType to proper TcRnMessage I've turned all occurrences of TcRnUnknownMessage in GHC.Rename.HsType module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnDataKindsError TcRnUnusedQuantifiedTypeVar TcRnIllegalKindSignature TcRnUnexpectedPatSigType TcRnSectionPrecedenceError TcRnPrecedenceParsingError TcRnIllegalKind TcRnNegativeNumTypeLiteral TcRnUnexpectedKindVar TcRnBindMultipleVariables TcRnBindVarAlreadyInScope - - - - - 220a7a48 by Krzysztof Gogolewski at 2023-04-03T19:32:02-04:00 Fixes around unsafeCoerce# 1. `unsafeCoerce#` was documented in `GHC.Prim`. But since the overhaul in 74ad75e87317, `unsafeCoerce#` is no longer defined there. I've combined the documentation in `GHC.Prim` with the `Unsafe.Coerce` module. 2. The documentation of `unsafeCoerce#` stated that you should not cast a function to an algebraic type, even if you later cast it back before applying it. But ghci was doing that type of cast, as can be seen with 'ghci -ddump-ds' and typing 'x = not'. I've changed it to use Any following the documentation. - - - - - 9095e297 by Matthew Craven at 2023-04-04T01:04:10-04:00 Add a few more memcpy-ish primops * copyMutableByteArrayNonOverlapping# * copyAddrToAddr# * copyAddrToAddrNonOverlapping# * setAddrRange# The implementations of copyBytes, moveBytes, and fillBytes in base:Foreign.Marshal.Utils now use these new primops, which can cause us to work a bit harder generating code for them, resulting in the metric increase in T21839c observed by CI on some architectures. But in exchange, we get better code! Metric Increase: T21839c - - - - - f7da530c by Matthew Craven at 2023-04-04T01:04:10-04:00 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. - - - - - cd00e321 by sheaf at 2023-04-04T01:04:50-04:00 Relax assertion in varToRecFieldOcc When using Template Haskell, it is possible to re-parent a field OccName belonging to one data constructor to another data constructor. The lsp-types package did this in order to "extend" a data constructor with additional fields. This ran into an assertion in 'varToRecFieldOcc'. This assertion can simply be relaxed, as the resulting splices are perfectly sound. Fixes #23220 - - - - - eed0d930 by Sylvain Henry at 2023-04-04T11:09:15-04:00 GHCi.RemoteTypes: fix doc and avoid unsafeCoerce (#23201) - - - - - 071139c3 by Ryan Scott at 2023-04-04T11:09:51-04:00 Make INLINE pragmas for pattern synonyms work with TH Previously, the code for converting `INLINE <name>` pragmas from TH splices used `vNameN`, which assumed that `<name>` must live in the variable namespace. Pattern synonyms, on the other hand, live in the constructor namespace. I've fixed the issue by switching to `vcNameN` instead, which works for both the variable and constructor namespaces. Fixes #23203. - - - - - 7c16f3be by Krzysztof Gogolewski at 2023-04-04T17:13:00-04:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). - - - - - c165f079 by sheaf at 2023-04-04T17:13:40-04:00 Add testcase for #23192 This issue around solving of constraints arising from superclass expansion using other constraints also borned from superclass expansion was the topic of commit aed1974e. That commit made sure we don't emit a "redundant constraint" warning in a situation in which removing the constraint would cause errors. Fixes #23192 - - - - - d1bb16ed by Ben Gamari at 2023-04-06T03:40:45-04:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 - - - - - 04b80850 by Brandon Chinn at 2023-04-06T03:41:21-04:00 Fix reverse flag for -Wunsupported-llvm-version - - - - - 0c990e13 by Pierre Le Marre at 2023-04-06T10:16:29+00:00 Add release note for GHC.Unicode refactor in base-4.18. Also merge CLC proposal 130 in base-4.19 with CLC proposal 59 in base-4.18 and add proper release date. - - - - - cbbfb283 by Alex Dixon at 2023-04-07T18:27:45-04:00 Improve documentation for ($) (#22963) - - - - - 5193c2b0 by Alex Dixon at 2023-04-07T18:27:45-04:00 Remove trailing whitespace from ($) commentary - - - - - b384523b by Sebastian Graf at 2023-04-07T18:27:45-04:00 Adjust wording wrt representation polymorphism of ($) - - - - - 6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00 Add structured error messages for GHC.Tc.TyCl.Utils Tracking ticket: #20117 MR: !10251 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00 Renamer: don't call addUsedGRE on an exact Name When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc, we could end up calling addUsedGRE on an exact Name, which would then lead to a panic in the bestImport function: it would be incapable of processing a GRE which is not local but also not brought into scope by any imports (as it is referred to by its unique instead). Fixes #23240 - - - - - bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00 Set base 'maintainer' field to CLC - - - - - ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00 Clarify a couple of Notes about 'nospec' - - - - - ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - f4f0ca72 by Adam Gundry at 2023-05-05T20:18:44+01:00 Tweak isAxiom_maybe to ignore non-newtype axioms See Note [Push transitivity inside newtype axioms only] for an explanation of the change here. This change substantially improves the performance of coercion optimization for programs involving transitive type family reductions. ------------------------- Metric Decrease: CoOpt_Singletons LargeRecord T12227 T12545 T13386 T15703 T5030 T8095 ------------------------- - - - - - e22c1c14 by Adam Gundry at 2023-05-05T20:18:44+01:00 Move checkAxInstCo to GHC.Core.Lint A consequence of the previous change is that checkAxInstCo is no longer called during coercion optimization, so it can be moved back where it belongs. - - - - - 13 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/darwin/nix/sources.json - .gitlab/darwin/toolchain.nix - + .gitlab/gen-ci.cabal - .gitlab/gen_ci.hs - + .gitlab/generate_job_metadata - .gitlab/generate_jobs - + .gitlab/hello.hs - + .gitlab/hie.yaml - .gitlab/jobs.yaml - .gitlab/merge_request_templates/merge-request.md The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32a2258f2d2652b96a8923b3b7b8ec5748332338...e22c1c143a1dc407a60f5cf9d3b393a54a99f0cc -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32a2258f2d2652b96a8923b3b7b8ec5748332338...e22c1c143a1dc407a60f5cf9d3b393a54a99f0cc You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun May 7 08:10:15 2023 From: gitlab at gitlab.haskell.org (Adam Gundry (@adamgundry)) Date: Sun, 07 May 2023 04:10:15 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/wip/tweak-co-opt Message-ID: <64575ce7537a6_e3e06604d24606554b2@gitlab.mail> Adam Gundry pushed new branch wip/wip/tweak-co-opt at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/wip/tweak-co-opt You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun May 7 08:11:27 2023 From: gitlab at gitlab.haskell.org (Adam Gundry (@adamgundry)) Date: Sun, 07 May 2023 04:11:27 -0400 Subject: [Git][ghc/ghc] Deleted branch wip/wip/tweak-co-opt Message-ID: <64575d2fba343_e3e0662cee4f86564f@gitlab.mail> Adam Gundry deleted branch wip/wip/tweak-co-opt at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun May 7 22:28:07 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Sun, 07 May 2023 18:28:07 -0400 Subject: [Git][ghc/ghc][wip/T23070-pipeline-monad] Further refactoring Message-ID: <645825f7295a3_38ffda5229c267dd@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23070-pipeline-monad at Glasgow Haskell Compiler / GHC Commits: 527a4943 by Simon Peyton Jones at 2023-05-07T23:25:00+01:00 Further refactoring In particular make the Irred pipeline one-stage (Just the Dict pipeline is left) - - - - - 9 changed files: - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Canonical.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Interact.hs - + compiler/GHC/Tc/Solver/Irred.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -277,8 +277,8 @@ floatKindEqualities wc = float_wc emptyVarSet wc = Nothing where is_floatable ct - | insolubleEqCt ct = False - | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs + | insolubleCt ct = False + | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError) float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs @@ -3396,7 +3396,7 @@ approximateWC float_past_equalities wc is_floatable encl_eqs skol_tvs ct | isGivenCt ct = False - | insolubleEqCt ct = False + | insolubleCt ct = False | tyCoVarsOfCt ct `intersectsVarSet` skol_tvs = False | otherwise = case classifyPredType (ctPred ct) of ===================================== compiler/GHC/Tc/Solver/Canonical.hs ===================================== @@ -17,7 +17,8 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Solver.Rewrite import GHC.Tc.Solver.Monad -import GHC.Tc.Solver.Equality( solveNonCanonicalEquality, solveCanonicalEquality ) +import GHC.Tc.Solver.Equality( solveEquality ) +import GHC.Tc.Solver.Irred( solveIrred ) import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm @@ -87,39 +88,52 @@ last time through, so we can skip the classification step. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ canonicalize :: Ct -> SolverStage Ct -canonicalize (CNonCanonical ev) - = canNC ev +canonicalize (CNonCanonical ev) = canNC ev +canonicalize (CIrredCan (IrredCt { ir_ev = ev })) = canNC ev -canonicalize (CEqCan can_eq_ct) - = solveCanonicalEquality can_eq_ct +canonicalize (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel + , eq_lhs = lhs, eq_rhs = rhs })) + = solveEquality ev eq_rel (canEqLHSType lhs) rhs canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = Stage $ canForAll ev pend_sc + = do { ev <- rewriteEvidence ev + ; case classifyPredType (ctEvPred ev) of + ForAllPred tvs th p -> Stage $ solveForAll ev tvs th p pend_sc + _ -> pprPanic "canonicalise" (ppr ev) } -canonicalize (CIrredCan (IrredCt { ir_ev = ev })) - = canNC ev - -- Instead of rewriting the evidence before classifying, it's possible we +canonicalize (CDictCan { cc_ev = ev, cc_pend_sc = pend_sc }) + = do { ev <- rewriteEvidence ev + ; case classifyPredType (ctEvPred ev) of + ClassPred cls tys -> Stage $ solveClass ev cls tys pend_sc + _ -> pprPanic "canonicalise" (ppr ev) } + +canNC :: CtEvidence -> SolverStage Ct +canNC ev + = -- Instead of rewriting the evidence before classifying, it's possible we -- can make progress without the rewrite. Try this first. -- For insolubles (all of which are equalities), do /not/ rewrite the arguments -- In #14350 doing so led entire-unnecessary and ridiculously large -- type function expansion. Instead, canEqNC just applies -- the substitution to the predicate, and may do decomposition; -- e.g. a ~ [a], where [G] a ~ [Int], can decompose + case classifyPredType (ctEvPred ev) of { + EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 ; + _ -> -canonicalize (CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis, cc_pend_sc = pend_sc }) - = {-# SCC "canClass" #-} - Stage $ canClass ev cls xis pend_sc + -- Do rewriting on the constraint, especially zonking + do { ev <- rewriteEvidence ev + ; let irred = IrredCt { ir_ev = ev, ir_reason = IrredShapeReason } -canNC :: CtEvidence -> SolverStage Ct -canNC ev = - case classifyPredType pred of - ClassPred cls tys -> Stage $ canClassNC ev cls tys - EqPred eq_rel ty1 ty2 -> solveNonCanonicalEquality ev eq_rel ty1 ty2 - IrredPred {} -> Stage $ canIrred ev - ForAllPred tvs th p -> Stage $ canForAllNC ev tvs th p - where - pred = ctEvPred ev + -- And then re-classify + ; case classifyPredType (ctEvPred ev) of + ClassPred cls tys -> Stage $ solveClassNC ev cls tys + ForAllPred tvs th p -> Stage $ solveForAllNC ev tvs th p + IrredPred {} -> solveIrred irred + EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 + -- This case only happens if (say) `c` is unified with `a ~# b`, + -- but that is rare becuase it requires c :: CONSTRAINT UnliftedRep + + }} {- ************************************************************************ @@ -129,19 +143,18 @@ canNC ev = ************************************************************************ -} -canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) --- "NC" means "non-canonical"; that is, we have got here --- from a NonCanonical constraint, not from a CDictCan --- Precondition: EvVar is class evidence -canClassNC ev cls tys +solveClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) +-- NC: this comes from CNonCanonical or CIrredCan +-- Precondition: already rewritten by inert set +solveClassNC ev cls tys | isGiven ev -- See Note [Eagerly expand given superclasses] = do { dflags <- getDynFlags ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev [] [] cls tys - -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] ; emitWork (listToBag sc_cts) - ; canClass ev cls tys doNotExpand } - -- doNotExpand: We have already expanded superclasses for /this/ dict - -- so set the fuel to doNotExpand to avoid repeating expansion + ; solveClass ev cls tys doNotExpand } + -- doNotExpand: We have already expanded superclasses for /this/ dict + -- so set the fuel to doNotExpand to avoid repeating expansion | CtWanted { ctev_rewriters = rewriters } <- ev , Just ip_name <- isCallStackPred cls tys @@ -167,24 +180,30 @@ canClassNC ev cls tys (ctLocSpan loc) (ctEvExpr new_ev) ; solveCallStack ev ev_cs - ; canClass new_ev cls tys doNotExpand - -- doNotExpand: No superclasses for class CallStack - -- See invariants in CDictCan.cc_pend_sc - } + ; solveClass new_ev cls tys doNotExpand } + -- doNotExpand: No superclasses for class CallStack + -- See invariants in CDictCan.cc_pend_sc | otherwise = do { dflags <- getDynFlags ; let fuel | classHasSCs cls = wantedsFuel dflags | otherwise = doNotExpand -- See Invariants in `CCDictCan.cc_pend_sc` - ; canClass ev cls tys fuel - } - + ; solveClass ev cls tys fuel } where loc = ctEvLoc ev orig = ctLocOrigin loc pred = ctEvPred ev +solveClass :: CtEvidence -> Class -> [Type] -> ExpansionFuel -> TcS (StopOrContinue Ct) +solveClass ev cls tys pend_sc + = -- Sll classes do *nominal* matching + assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ + continueWith (CDictCan { cc_ev = ev + , cc_tyargs = tys + , cc_class = cls + , cc_pend_sc = pend_sc }) + solveCallStack :: CtEvidence -> EvCallStack -> TcS () -- Also called from GHC.Tc.Solver when defaulting call stacks solveCallStack ev ev_cs = do @@ -195,25 +214,6 @@ solveCallStack ev ev_cs = do let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev)) setEvBindIfWanted ev IsCoherent ev_tm -canClass :: CtEvidence - -> Class -> [Type] - -> ExpansionFuel -- n > 0 <=> un-explored superclasses - -> TcS (StopOrContinue Ct) --- Precondition: EvVar is class evidence - -canClass ev cls tys pend_sc - = -- all classes do *nominal* matching - assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ - do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys - ; let redn = mkClassPredRedn cls redns - ; rewriteEvidence rewriters ev redn $ \new_ev -> - do { traceTcS "canClass" (vcat [ ppr new_ev, ppr (reductionReducedType redn) ]) - ; continueWith (CDictCan { cc_ev = new_ev - , cc_tyargs = xis - , cc_class = cls - , cc_pend_sc = pend_sc }) }} - where - cls_tc = classTyCon cls {- Note [The superclass story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -715,40 +715,8 @@ which looks for primitive equalities specially in the quantified constraints. See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. - - -************************************************************************ -* * -* Irreducibles canonicalization -* * -************************************************************************ -} -canIrred :: CtEvidence -> TcS (StopOrContinue Ct) --- Precondition: ty not a tuple and no other evidence form -canIrred ev - = do { let pred = ctEvPred ev - ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) - ; (redn, rewriters) <- rewrite ev pred - ; rewriteEvidence rewriters ev redn $ \ new_ev -> - - do { -- Re-classify, in case rewriting has improved its shape - -- Code is like the canNC, except - -- that the IrredPred branch stops work - ; case classifyPredType (ctEvPred new_ev) of - ClassPred cls tys -> canClassNC new_ev cls tys - EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so - -- cannot become EqPreds - pprPanic "canIrred: EqPred" - (ppr ev $$ ppr eq_rel $$ ppr ty1 $$ ppr ty2) - ForAllPred tvs th p -> -- this is highly suspect; Quick Look - -- should never leave a meta-var filled - -- in with a polytype. This is #18987. - do traceTcS "canEvNC:forall" (ppr pred) - canForAllNC ev tvs th p - IrredPred {} -> continueWith $ - mkIrredCt IrredShapeReason new_ev } } - {- ********************************************************************* * * * Quantified predicates @@ -827,16 +795,18 @@ type signature. -} -canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType - -> TcS (StopOrContinue Ct) -canForAllNC ev tvs theta pred +solveForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType + -> TcS (StopOrContinue Ct) +-- NC: this came from CNonCanonical, so we have not yet expanded superclasses +-- Precondition: already rewritten by inert set +solveForAllNC ev tvs theta pred | isGiven ev -- See Note [Eagerly expand given superclasses] , Just (cls, tys) <- cls_pred_tys_maybe = do { dflags <- getDynFlags ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] ; emitWork (listToBag sc_cts) - ; canForAll ev doNotExpand } + ; solveForAll ev tvs theta pred doNotExpand } -- doNotExpand: as we have already (eagerly) expanded superclasses for this class | otherwise @@ -847,27 +817,13 @@ canForAllNC ev tvs theta pred -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] -- See Note [Quantified constraints] | otherwise = doNotExpand - ; canForAll ev fuel } + ; solveForAll ev tvs theta pred fuel } where cls_pred_tys_maybe = getClassPredTys_maybe pred -canForAll :: CtEvidence -> ExpansionFuel -> TcS (StopOrContinue Ct) --- We have a constraint (forall as. blah => C tys) -canForAll ev fuel - = do { -- First rewrite it to apply the current substitution - ; (redn, rewriters) <- rewrite ev (ctEvPred ev) - ; rewriteEvidence rewriters ev redn $ \ new_ev -> - - do { -- Now decompose into its pieces and solve it - -- (It takes a lot less code to rewrite before decomposing.) - ; case classifyPredType (ctEvPred new_ev) of - ForAllPred tvs theta pred - -> solveForAll new_ev tvs theta pred fuel - _ -> pprPanic "canForAll" (ppr new_ev) - } } - solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> ExpansionFuel -> TcS (StopOrContinue Ct) +-- Precondition: already rewritten by inert set solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc }) tvs theta pred _fuel = -- See Note [Solving a Wanted forall-constraint] @@ -966,12 +922,7 @@ we'll find a match in the InstEnv. ************************************************************************ -} -rewriteEvidence :: RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] - -- in GHC.Tc.Types.Constraint - -> CtEvidence -- ^ old evidence - -> Reduction -- ^ new predicate + coercion, of type ~ new predicate - -> (CtEvidence -> TcS (StopOrContinue Ct)) - -> TcS (StopOrContinue Ct) +rewriteEvidence :: CtEvidence -> SolverStage CtEvidence -- (rewriteEvidence old_ev new_pred co do_next) -- Main purpose: create new evidence for new_pred; -- unless new_pred is cached already @@ -1005,33 +956,42 @@ the rewriter set. We check this with an assertion. -} -rewriteEvidence rewriters old_ev (Reduction co new_pred) do_next +rewriteEvidence ev + = Stage $ do { traceTcS "rewriteEvidence" (ppr ev) + ; (redn, rewriters) <- rewrite ev (ctEvPred ev) + ; finish_rewrite ev redn rewriters } + +finish_rewrite :: CtEvidence -- ^ old evidence + -> Reduction -- ^ new predicate + coercion, of type ~ new predicate + -> RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Types.Constraint + -> TcS (StopOrContinue CtEvidence) +finish_rewrite old_ev (Reduction co new_pred) rewriters | isReflCo co -- See Note [Rewriting with Refl] = assert (isEmptyRewriterSet rewriters) $ - do_next (setCtEvPredType old_ev new_pred) + continueWith (setCtEvPredType old_ev new_pred) -rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) - (Reduction co new_pred) do_next +finish_rewrite ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) + (Reduction co new_pred) rewriters = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted do { new_ev <- newGivenEvVar loc (new_pred, new_tm) - ; do_next new_ev } + ; continueWith new_ev } where -- mkEvCast optimises ReflCo new_tm = mkEvCast (evId old_evar) (downgradeRole Representational (ctEvRole ev) co) -rewriteEvidence new_rewriters - ev@(CtWanted { ctev_dest = dest +finish_rewrite ev@(CtWanted { ctev_dest = dest , ctev_loc = loc , ctev_rewriters = rewriters }) - (Reduction co new_pred) do_next + (Reduction co new_pred) new_rewriters = do { mb_new_ev <- newWanted loc rewriters' new_pred ; massert (coercionRole co == ctEvRole ev) ; setWantedEvTerm dest IsCoherent $ mkEvCast (getEvExpr mb_new_ev) (downgradeRole Representational (ctEvRole ev) (mkSymCo co)) ; case mb_new_ev of - Fresh new_ev -> do_next new_ev + Fresh new_ev -> continueWith new_ev Cached _ -> stopWith ev "Cached wanted" } where rewriters' = rewriters S.<> new_rewriters ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -2,7 +2,7 @@ {-# LANGUAGE MultiWayIf #-} module GHC.Tc.Solver.Equality( - solveCanonicalEquality, solveNonCanonicalEquality + solveEquality ) where @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Tc.Solver.Rewrite import GHC.Tc.Solver.Monad +import GHC.Tc.Solver.Irred( tryInertIrreds ) import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Types( findFunEqsByTyCon ) @@ -100,14 +101,9 @@ It's as if we treat (->) and (=>) as different type constructors, which indeed they are! -} -solveCanonicalEquality :: EqCt -> SolverStage Ct -solveCanonicalEquality (EqCt { eq_ev = ev, eq_eq_rel = eq_rel - , eq_lhs = lhs, eq_rhs = rhs }) - = solveNonCanonicalEquality ev eq_rel (canEqLHSType lhs) rhs - -solveNonCanonicalEquality :: CtEvidence -> EqRel -> Type -> Type - -> SolverStage Ct -solveNonCanonicalEquality ev eq_rel ty1 ty2 +solveEquality :: CtEvidence -> EqRel -> Type -> Type + -> SolverStage Ct +solveEquality ev eq_rel ty1 ty2 = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2 ; let ev' | debugIsOn = setCtEvPredType ev $ mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2' @@ -118,12 +114,12 @@ solveNonCanonicalEquality ev eq_rel ty1 ty2 ; case mb_canon of { - Left irred_ct -> do { solveIrredEquality irred_ct + Left irred_ct -> do { tryInertIrreds irred_ct ; return (CIrredCan irred_ct) } ; Right eq_ct -> do { interactEq eq_ct ; tryFunDeps eq_ct - ; tryQuantifiedConstraints eq_ct + ; tryQCsEqCt eq_ct ; return (CEqCan eq_ct) } } } @@ -2674,8 +2670,9 @@ See -} -------------------- -solveIrredEquality :: IrredCt -> SolverStage () -solveIrredEquality irred@(IrredCt { ir_ev = ev }) +{- +tryQCsIrredCt :: IrredCt -> SolverStage () +tryQCsIrredCt irred@(IrredCt { ir_ev = ev }) | EqPred eq_rel t1 t2 <- classifyPredType (ctEvPred ev) = lookup_eq_in_qcis (CIrredCan irred) eq_rel t1 t2 -- If the final_qci_check fails, we'll do continueWith on an IrredCt @@ -2689,10 +2686,11 @@ solveIrredEquality irred@(IrredCt { ir_ev = ev }) -- this can't happen case, but it's not a hot path, and this is -- simple and robust = pprPanic "solveIrredEquality" (ppr ev) +-} -------------------- -tryQuantifiedConstraints :: EqCt -> SolverStage () -tryQuantifiedConstraints work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel }) +tryQCsEqCt :: EqCt -> SolverStage () +tryQCsEqCt work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel }) = lookup_eq_in_qcis (CEqCan work_item) eq_rel (canEqLHSType lhs) rhs -------------------- @@ -2701,6 +2699,8 @@ lookup_eq_in_qcis :: Ct -> EqRel -> TcType -> TcType -> SolverStage () -- [W] t1 ~# t2 -- and a Given quantified contraint like (forall a b. blah => a ~ b) -- Why? See Note [Looking up primitive equalities in quantified constraints] +-- See also GHC.Tc.Solver.Canonical +-- Note [Equality superclasses in quantified constraints] lookup_eq_in_qcis work_ct eq_rel lhs rhs = Stage $ do { ev_binds_var <- getTcEvBindsVar ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -42,7 +42,10 @@ module GHC.Tc.Solver.InertSet ( CycleBreakerVarStack, pushCycleBreakerVarStack, addCycleBreakerBindings, - forAllCycleBreakerBindings_ + forAllCycleBreakerBindings_, + + -- * Solving one from another + InteractResult(..), solveOneFromTheOther ) where @@ -65,15 +68,17 @@ import GHC.Core.Class( Class ) import GHC.Core.TyCon import GHC.Core.Unify -import GHC.Data.Bag import GHC.Utils.Misc ( partitionWith ) import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Data.Maybe +import GHC.Data.Bag import Data.List.NonEmpty ( NonEmpty(..), (<|) ) import qualified Data.List.NonEmpty as NE -import GHC.Utils.Panic.Plain -import GHC.Data.Maybe +import Data.Function ( on ) + import Control.Monad ( forM_ ) {- @@ -1945,3 +1950,198 @@ forAllCycleBreakerBindings_ :: Monad m forAllCycleBreakerBindings_ (top_env :| _rest_envs) action = forM_ top_env (uncurry action) {-# INLINABLE forAllCycleBreakerBindings_ #-} -- to allow SPECIALISE later + + +{- ********************************************************************* +* * + Solving one from another +* * +********************************************************************* -} + +data InteractResult + = KeepInert -- Keep the inert item, and solve the work item from it + -- (if the latter is Wanted; just discard it if not) + | KeepWork -- Keep the work item, and solve the inert item from it + +instance Outputable InteractResult where + ppr KeepInert = text "keep inert" + ppr KeepWork = text "keep work-item" + +solveOneFromTheOther :: Ct -- Inert (Dict or Irred) + -> Ct -- WorkItem (same predicate as inert) + -> InteractResult +-- Precondition: +-- * inert and work item represent evidence for the /same/ predicate +-- * Both are CDictCan or CIrredCan +-- +-- We can always solve one from the other: even if both are wanted, +-- although we don't rewrite wanteds with wanteds, we can combine +-- two wanteds into one by solving one from the other + +solveOneFromTheOther ct_i ct_w + | CtWanted { ctev_loc = loc_w } <- ev_w + , prohibitedSuperClassSolve loc_i loc_w + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + = -- Inert must be Given + KeepWork + + | CtWanted {} <- ev_w + = -- Inert is Given or Wanted + case ev_i of + CtGiven {} -> KeepInert + -- work is Wanted; inert is Given: easy choice. + + CtWanted {} -- Both are Wanted + -- If only one has no pending superclasses, use it + -- Otherwise we can get infinite superclass expansion (#22516) + -- in silly cases like class C T b => C a b where ... + | not is_psc_i, is_psc_w -> KeepInert + | is_psc_i, not is_psc_w -> KeepWork + + -- If only one is a WantedSuperclassOrigin (arising from expanding + -- a Wanted class constraint), keep the other: wanted superclasses + -- may be unexpected by users + | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert + | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork + + -- otherwise, just choose the lower span + -- reason: if we have something like (abs 1) (where the + -- Num constraint cannot be satisfied), it's better to + -- get an error about abs than about 1. + -- This test might become more elaborate if we see an + -- opportunity to improve the error messages + | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert + | otherwise -> KeepWork + + -- From here on the work-item is Given + + | CtWanted { ctev_loc = loc_i } <- ev_i + , prohibitedSuperClassSolve loc_w loc_i + = KeepInert -- Just discard the un-usable Given + -- This never actually happens because + -- Givens get processed first + + | CtWanted {} <- ev_i + = KeepWork + + -- From here on both are Given + -- See Note [Replacement vs keeping] + + | lvl_i == lvl_w + = same_level_strategy + + | otherwise -- Both are Given, levels differ + = different_level_strategy + where + ev_i = ctEvidence ct_i + ev_w = ctEvidence ct_w + + pred = ctEvPred ev_i + + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w + orig_i = ctLocOrigin loc_i + orig_w = ctLocOrigin loc_w + lvl_i = ctLocLevel loc_i + lvl_w = ctLocLevel loc_w + + is_psc_w = isPendingScDict ct_w + is_psc_i = isPendingScDict ct_i + + is_wsc_orig_i = isWantedSuperclassOrigin orig_i + is_wsc_orig_w = isWantedSuperclassOrigin orig_w + + different_level_strategy -- Both Given + | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert + | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork + -- See Note [Replacement vs keeping] part (1) + -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters] + + same_level_strategy -- Both Given + = case (orig_i, orig_w) of + + (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w) + | blocked_i, not blocked_w -> KeepWork -- Case 2(a) from + | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping] + + -- Both blocked or both not blocked + + | depth_w < depth_i -> KeepWork -- Case 2(c) from + | otherwise -> KeepInert -- Note [Replacement vs keeping] + + (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping] + + _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping] + +{- +Note [Replacement vs keeping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have two Given constraints both of type (C tys), say, which should +we keep? More subtle than you might think! This is all implemented in +solveOneFromTheOther. + + 1) Constraints come from different levels (different_level_strategy) + + - For implicit parameters we want to keep the innermost (deepest) + one, so that it overrides the outer one. + See Note [Shadowing of Implicit Parameters] + + - For everything else, we want to keep the outermost one. Reason: that + makes it more likely that the inner one will turn out to be unused, + and can be reported as redundant. See Note [Tracking redundant constraints] + in GHC.Tc.Solver. + + It transpires that using the outermost one is responsible for an + 8% performance improvement in nofib cryptarithm2, compared to + just rolling the dice. I didn't investigate why. + + 2) Constraints coming from the same level (i.e. same implication) + + (a) If both are GivenSCOrigin, choose the one that is unblocked if possible + according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. + + (b) Prefer constraints that are not superclass selections. Example: + + f :: (Eq a, Ord a) => a -> Bool + f x = x == x + + Eager superclass expansion gives us two [G] Eq a constraints. We + want to keep the one from the user-written Eq a, not the superclass + selection. This means we report the Ord a as redundant with + -Wredundant-constraints, not the Eq a. + + Getting this wrong was #20602. See also + Note [Tracking redundant constraints] in GHC.Tc.Solver. + + (c) If both are GivenSCOrigin, chooose the one with the shallower + superclass-selection depth, in the hope of identifying more correct + redundant constraints. This is really a generalization of point (b), + because the superclass depth of a non-superclass constraint is 0. + + (If the levels differ, we definitely won't have both with GivenSCOrigin.) + + (d) Finally, when there is still a choice, use KeepInert rather than + KeepWork, for two reasons: + - to avoid unnecessary munging of the inert set. + - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical + +Doing the level-check for implicit parameters, rather than making the work item +always override, is important. Consider + + data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } + + f :: (?x::a) => T a -> Int + f T1 = ?x + f T2 = 3 + +We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add +two new givens in the work-list: [G] (?x::Int) + [G] (a ~ Int) +Now consider these steps + - process a~Int, kicking out (?x::a) + - process (?x::Int), the inner given, adding to inert set + - process (?x::a), the outer given, overriding the inner given +Wrong! The level-check ensures that the inner implicit parameter wins. +(Actually I think that the order in which the work-list is processed means +that this chain of events won't happen, but that's very fragile.) +-} \ No newline at end of file ===================================== compiler/GHC/Tc/Solver/Interact.hs ===================================== @@ -15,19 +15,17 @@ import GHC.Tc.Instance.Class ( safeOverlap ) import GHC.Tc.Types.Evidence import GHC.Tc.Types import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin import GHC.Tc.Solver.Types import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Core.InstEnv ( Coherence(..) ) import GHC.Core.Predicate -import GHC.Core.Coercion import GHC.Builtin.Names ( ipClassKey ) import GHC.Types.Unique( hasKey ) -import GHC.Types.Basic ( SwapFlag(..), IntWithInf, intGtLimit ) +import GHC.Types.Basic ( IntWithInf, intGtLimit ) import GHC.Data.Bag @@ -41,7 +39,6 @@ import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import Data.List( deleteFirstsBy ) -import Data.Function ( on ) import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe @@ -414,262 +411,15 @@ interactWithInertsStage wi do { inerts <- getTcSInerts ; let ics = inert_cans inerts ; case wi of - CIrredCan ir_ct -> interactIrred ics ir_ct - CDictCan {} -> interactDict ics wi - CEqCan {} -> continueWith wi -- "Canonicalisation" stage is - -- full solver for equalities + CDictCan {} -> interactDict ics wi + CEqCan {} -> continueWith wi -- "Canonicalisation" stage is + -- full solver for equalities + CIrredCan {} -> continueWith wi -- Ditto Irreds _ -> pprPanic "interactWithInerts" (ppr wi) } -- CNonCanonical have been canonicalised -data InteractResult - = KeepInert -- Keep the inert item, and solve the work item from it - -- (if the latter is Wanted; just discard it if not) - | KeepWork -- Keep the work item, and solve the inert item from it - -instance Outputable InteractResult where - ppr KeepInert = text "keep inert" - ppr KeepWork = text "keep work-item" - -solveOneFromTheOther :: Ct -- Inert (Dict or Irred) - -> Ct -- WorkItem (same predicate as inert) - -> InteractResult --- Precondition: --- * inert and work item represent evidence for the /same/ predicate --- * Both are CDictCan or CIrredCan --- --- We can always solve one from the other: even if both are wanted, --- although we don't rewrite wanteds with wanteds, we can combine --- two wanteds into one by solving one from the other - -solveOneFromTheOther ct_i ct_w - | CtWanted { ctev_loc = loc_w } <- ev_w - , prohibitedSuperClassSolve loc_i loc_w - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - = -- Inert must be Given - KeepWork - - | CtWanted {} <- ev_w - = -- Inert is Given or Wanted - case ev_i of - CtGiven {} -> KeepInert - -- work is Wanted; inert is Given: easy choice. - - CtWanted {} -- Both are Wanted - -- If only one has no pending superclasses, use it - -- Otherwise we can get infinite superclass expansion (#22516) - -- in silly cases like class C T b => C a b where ... - | not is_psc_i, is_psc_w -> KeepInert - | is_psc_i, not is_psc_w -> KeepWork - - -- If only one is a WantedSuperclassOrigin (arising from expanding - -- a Wanted class constraint), keep the other: wanted superclasses - -- may be unexpected by users - | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert - | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork - - -- otherwise, just choose the lower span - -- reason: if we have something like (abs 1) (where the - -- Num constraint cannot be satisfied), it's better to - -- get an error about abs than about 1. - -- This test might become more elaborate if we see an - -- opportunity to improve the error messages - | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert - | otherwise -> KeepWork - - -- From here on the work-item is Given - - | CtWanted { ctev_loc = loc_i } <- ev_i - , prohibitedSuperClassSolve loc_w loc_i - = KeepInert -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first - - | CtWanted {} <- ev_i - = KeepWork - - -- From here on both are Given - -- See Note [Replacement vs keeping] - - | lvl_i == lvl_w - = same_level_strategy - - | otherwise -- Both are Given, levels differ - = different_level_strategy - where - ev_i = ctEvidence ct_i - ev_w = ctEvidence ct_w - - pred = ctEvPred ev_i - - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - orig_i = ctLocOrigin loc_i - orig_w = ctLocOrigin loc_w - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w - - is_psc_w = isPendingScDict ct_w - is_psc_i = isPendingScDict ct_i - - is_wsc_orig_i = isWantedSuperclassOrigin orig_i - is_wsc_orig_w = isWantedSuperclassOrigin orig_w - - different_level_strategy -- Both Given - | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert - | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork - -- See Note [Replacement vs keeping] part (1) - -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters] - - same_level_strategy -- Both Given - = case (orig_i, orig_w) of - - (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w) - | blocked_i, not blocked_w -> KeepWork -- Case 2(a) from - | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping] - - -- Both blocked or both not blocked - - | depth_w < depth_i -> KeepWork -- Case 2(c) from - | otherwise -> KeepInert -- Note [Replacement vs keeping] - - (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping] - - _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping] - -{- -Note [Replacement vs keeping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have two Given constraints both of type (C tys), say, which should -we keep? More subtle than you might think! This is all implemented in -solveOneFromTheOther. - - 1) Constraints come from different levels (different_level_strategy) - - - For implicit parameters we want to keep the innermost (deepest) - one, so that it overrides the outer one. - See Note [Shadowing of Implicit Parameters] - - - For everything else, we want to keep the outermost one. Reason: that - makes it more likely that the inner one will turn out to be unused, - and can be reported as redundant. See Note [Tracking redundant constraints] - in GHC.Tc.Solver. - - It transpires that using the outermost one is responsible for an - 8% performance improvement in nofib cryptarithm2, compared to - just rolling the dice. I didn't investigate why. - - 2) Constraints coming from the same level (i.e. same implication) - - (a) If both are GivenSCOrigin, choose the one that is unblocked if possible - according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - - (b) Prefer constraints that are not superclass selections. Example: - - f :: (Eq a, Ord a) => a -> Bool - f x = x == x - - Eager superclass expansion gives us two [G] Eq a constraints. We - want to keep the one from the user-written Eq a, not the superclass - selection. This means we report the Ord a as redundant with - -Wredundant-constraints, not the Eq a. - - Getting this wrong was #20602. See also - Note [Tracking redundant constraints] in GHC.Tc.Solver. - - (c) If both are GivenSCOrigin, chooose the one with the shallower - superclass-selection depth, in the hope of identifying more correct - redundant constraints. This is really a generalization of point (b), - because the superclass depth of a non-superclass constraint is 0. - - (If the levels differ, we definitely won't have both with GivenSCOrigin.) - - (d) Finally, when there is still a choice, use KeepInert rather than - KeepWork, for two reasons: - - to avoid unnecessary munging of the inert set. - - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical - -Doing the level-check for implicit parameters, rather than making the work item -always override, is important. Consider - data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } - - f :: (?x::a) => T a -> Int - f T1 = ?x - f T2 = 3 - -We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add -two new givens in the work-list: [G] (?x::Int) - [G] (a ~ Int) -Now consider these steps - - process a~Int, kicking out (?x::a) - - process (?x::Int), the inner given, adding to inert set - - process (?x::a), the outer given, overriding the inner given -Wrong! The level-check ensures that the inner implicit parameter wins. -(Actually I think that the order in which the work-list is processed means -that this chain of events won't happen, but that's very fragile.) - -********************************************************************************* -* * - interactIrred -* * -********************************************************************************* - -Note [Multiple matching irreds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that it's impossible to have multiple irreds all match the -work item; after all, interactIrred looks for matches and solves one from the -other. However, note that interacting insoluble, non-droppable irreds does not -do this matching. We thus might end up with several insoluble, non-droppable, -matching irreds in the inert set. When another irred comes along that we have -not yet labeled insoluble, we can find multiple matches. These multiple matches -cause no harm, but it would be wrong to ASSERT that they aren't there (as we -once had done). This problem can be tickled by typecheck/should_compile/holes. - --} - --- Two pieces of irreducible evidence: if their types are *exactly identical* --- we can rewrite them. We can never improve using this: --- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not --- mean that (ty1 ~ ty2) -interactIrred :: InertCans -> IrredCt -> TcS (StopOrContinue Ct) - -interactIrred inerts irred_w@(IrredCt { ir_ev = ev_w, ir_reason = reason }) - | isInsolubleReason reason - -- For insolubles, don't allow the constraint to be dropped - -- which can happen with solveOneFromTheOther, so that - -- we get distinct error messages with -fdefer-type-errors - = carry_on - - | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w - , ((irred_i, swap) : _rest) <- bagToList matching_irreds - -- See Note [Multiple matching irreds] - , let ev_i = irredCtEvidence irred_i - ct_i = CIrredCan irred_i - = do { traceTcS "iteractIrred" $ - vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w)) - , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ] - ; case solveOneFromTheOther ct_i ct_w of - KeepInert -> do { setEvBindIfWanted ev_w IsCoherent (swap_me swap ev_i) - ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) } - KeepWork -> do { setEvBindIfWanted ev_i IsCoherent (swap_me swap ev_w) - ; updInertIrreds (\_ -> others) - ; carry_on } } - - | otherwise - = carry_on - - where - ct_w = CIrredCan irred_w - carry_on = continueWith ct_w - - swap_me :: SwapFlag -> CtEvidence -> EvTerm - swap_me swap ev - = case swap of - NotSwapped -> ctEvTerm ev - IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) - -{- -********************************************************************************* +{- ****************************************************************************** * * interactDict * * @@ -1192,42 +942,10 @@ topReactionsStage :: Ct -> SolverStage Ct -- so try interaction with top-level instances. topReactionsStage work_item = Stage $ - do { traceTcS "doTopReact" (ppr work_item) - ; case work_item of - - CDictCan {} -> - do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } - - CEqCan {} -> continueWith work_item -- "Canonicalisation" stage is - -- full solver for equalities - - CIrredCan {} -> - doTopReactOther work_item + do { case work_item of + CDictCan {} -> do { inerts <- getTcSInerts + ; doTopReactDict inerts work_item } -- Any other work item does not react with any top-level equations _ -> continueWith work_item } --------------------- -doTopReactOther :: Ct -> TcS (StopOrContinue Ct) --- Try local quantified constraints for --- CEqCan e.g. (lhs ~# ty) --- and CIrredCan e.g. (c a) --- --- Why equalities? See GHC.Tc.Solver.Canonical --- Note [Equality superclasses in quantified constraints] -doTopReactOther work_item - | isGiven ev - = continueWith work_item - - | otherwise - = do { res <- matchLocalInst pred loc - ; case res of - OneInst {} -> chooseInstance ev res - _ -> continueWith work_item } - - where - ev = ctEvidence work_item - loc = ctEvLoc ev - pred = ctEvPred ev - ===================================== compiler/GHC/Tc/Solver/Irred.hs ===================================== @@ -0,0 +1,124 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} + +module GHC.Tc.Solver.Irred( + solveIrred, tryInertIrreds + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) +import GHC.Tc.Solver.Monad +import GHC.Tc.Types.Evidence + +import GHC.Core.Coercion +import GHC.Core.InstEnv ( Coherence(..) ) + +import GHC.Types.Basic( SwapFlag(..) ) + +import GHC.Utils.Outputable + + +import GHC.Data.Bag + + +{- ********************************************************************* +* * +* Irreducibles +* * +********************************************************************* -} + +solveIrred :: IrredCt -> SolverStage Ct +solveIrred irred + = do { tryInertIrreds irred + ; tryQCsIrredCt irred + ; return (CIrredCan irred) } + +{- ********************************************************************* +* * +* Inert Irreducibles +* * +********************************************************************* -} + +-- Two pieces of irreducible evidence: if their types are *exactly identical* +-- we can rewrite them. We can never improve using this: +-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not +-- mean that (ty1 ~ ty2) +tryInertIrreds :: IrredCt -> SolverStage () +tryInertIrreds irred + = Stage $ do { ics <- getInertCans + ; try_inert_irreds ics irred } + +try_inert_irreds :: InertCans -> IrredCt -> TcS (StopOrContinue ()) + +try_inert_irreds inerts irred_w@(IrredCt { ir_ev = ev_w, ir_reason = reason }) + | isInsolubleReason reason + -- For insolubles, don't allow the constraint to be dropped + -- which can happen with solveOneFromTheOther, so that + -- we get distinct error messages with -fdefer-type-errors + = continueWith () + + | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w + , ((irred_i, swap) : _rest) <- bagToList matching_irreds + -- See Note [Multiple matching irreds] + , let ev_i = irredCtEvidence irred_i + ct_i = CIrredCan irred_i + = do { traceTcS "iteractIrred" $ + vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w)) + , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ] + ; case solveOneFromTheOther ct_i ct_w of + KeepInert -> do { setEvBindIfWanted ev_w IsCoherent (swap_me swap ev_i) + ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) } + KeepWork -> do { setEvBindIfWanted ev_i IsCoherent (swap_me swap ev_w) + ; updInertIrreds (\_ -> others) + ; continueWith () } } + + | otherwise + = continueWith () + + where + ct_w = CIrredCan irred_w + + swap_me :: SwapFlag -> CtEvidence -> EvTerm + swap_me swap ev + = case swap of + NotSwapped -> ctEvTerm ev + IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) + + +{- Note [Multiple matching irreds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that it's impossible to have multiple irreds all match the +work item; after all, interactIrred looks for matches and solves one from the +other. However, note that interacting insoluble, non-droppable irreds does not +do this matching. We thus might end up with several insoluble, non-droppable, +matching irreds in the inert set. When another irred comes along that we have +not yet labeled insoluble, we can find multiple matches. These multiple matches +cause no harm, but it would be wrong to ASSERT that they aren't there (as we +once had done). This problem can be tickled by typecheck/should_compile/holes. +-} + +{- ********************************************************************* +* * +* Quantified constraints +* * +********************************************************************* -} + +tryQCsIrredCt :: IrredCt -> SolverStage () +-- Try local quantified constraints for +-- and CIrredCan e.g. (c a) +tryQCsIrredCt (IrredCt { ir_ev = ev }) + | isGiven ev + = Stage $ continueWith () + + | otherwise + = Stage $ do { res <- matchLocalInst pred loc + ; case res of + OneInst {} -> chooseInstance ev res + _ -> continueWith () } + where + loc = ctEvLoc ev + pred = ctEvPred ev ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -354,7 +354,7 @@ addInertCan ct = do { traceTcS "addInertCan {" $ text "Trying to insert new inert item:" <+> ppr ct ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} -> - when (abort_flag && insolubleEqCt ct) TcM.failM) + when (abort_flag && insolubleCt ct) TcM.failM) ; ics <- getInertCans ; ics <- maybeKickOut ics ct ; tclvl <- getTcLevel ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -57,7 +57,7 @@ module GHC.Tc.Types.Constraint ( addInsols, dropMisleading, addSimples, addImplics, addHoles, addNotConcreteError, addDelayedErrors, tyCoVarsOfWC, tyCoVarsOfWCList, - insolubleWantedCt, insolubleEqCt, insolubleCt, insolubleIrredCt, + insolubleWantedCt, insolubleCt, insolubleIrredCt, insolubleImplic, nonDefaultableTyVarsOfWC, Implication(..), implicationPrototype, checkTelescopeSkol, @@ -1306,30 +1306,13 @@ insolubleWantedCt ct = insolubleCt ct && not (arisesFromGivens ct) && not (isWantedWantedFunDepOrigin (ctOrigin ct)) -insolubleEqCt :: Ct -> Bool --- Returns True of /equality/ constraints --- that are /definitely/ insoluble --- It won't detect some definite errors like --- F a ~ T (F a) --- where F is a type family, which actually has an occurs check --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- E.g. It'll reply True for a ~ [a] --- but False for [a] ~ a --- and --- True for Int ~ F a Int --- but False for Maybe Int ~ F a Int Int --- (where F is an arity-1 type function) -insolubleEqCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct -insolubleEqCt _ = False - insolubleIrredCt :: IrredCt -> Bool +-- Returns True of Irred constraints that are /definitely/ insoluble insolubleIrredCt (IrredCt { ir_reason = reason }) = isInsolubleReason reason --- | Returns True of equality constraints that are definitely insoluble, --- as well as TypeError constraints. +-- | Returns True of constraints that are definitely insoluble, +-- as well as TypeError constraints. -- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. -- -- This function is critical for accurate pattern-match overlap warnings. @@ -1338,8 +1321,15 @@ insolubleIrredCt (IrredCt { ir_reason = reason }) -- Note that this does not traverse through the constraint to find -- nested custom type errors: it only detects @TypeError msg :: Constraint@, -- and not e.g. @Eq (TypeError msg)@. +-- +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- That's why it looks only for IrredCt, with an insoluble IrredCtReason insolubleCt :: Ct -> Bool -insolubleCt ct = isTopLevelUserTypeError (ctPred ct) || insolubleEqCt ct +insolubleCt ct + | isTopLevelUserTypeError (ctPred ct) = True + | CIrredCan ir_ct <- ct = insolubleIrredCt ir_ct + | otherwise = False where -- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg" -- and "Unsatisfiable msg". It deliberately does not detect TypeError ===================================== compiler/ghc.cabal.in ===================================== @@ -726,6 +726,7 @@ Library GHC.Tc.Solver.Rewrite GHC.Tc.Solver.InertSet GHC.Tc.Solver.Interact + GHC.Tc.Solver.Irred GHC.Tc.Solver.Equality GHC.Tc.Solver.Dict GHC.Tc.Solver.Monad View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/527a494351981a89b88af927ef144976556e7c7d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/527a494351981a89b88af927ef144976556e7c7d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 02:58:31 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Sun, 07 May 2023 22:58:31 -0400 Subject: [Git][ghc/ghc][wip/expand-do] something good in sight Message-ID: <645865576d8be_38ffda13269c20566ab@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 36c56e5c by Apoorv Ingle at 2023-05-07T21:57:54-05:00 something good in sight - - - - - 18 changed files: - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Constructor.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Types/Basic.hs Changes: ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -45,7 +45,7 @@ module GHC.Hs.Utils( mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, - mkHsDictLet, mkHsLams, + mkHsDictLet, mkHsLams, mkHsLamDoExp, mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, mkHsCmdIf, mkConLikeTc, @@ -271,7 +271,17 @@ mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) -> LHsExpr (GhcPass p) mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) where - matches = mkMatchGroup Generated + matches = mkMatchGroup (Generated OtherExpansion) + (noLocA [mkSimpleMatch LambdaExpr pats' body]) + pats' = map (parenthesizePat appPrec) pats + +mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) + => [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) + -> LHsExpr (GhcPass p) +mkHsLamDoExp pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) + where + matches = mkMatchGroup (Generated DoExpansion) (noLocA [mkSimpleMatch LambdaExpr pats' body]) pats' = map (parenthesizePat appPrec) pats @@ -599,7 +609,7 @@ nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs -- AZ:Is this used? -nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match]))) +nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup (Generated OtherExpansion) (noLocA [match]))) nlHsPar e = noLocA (gHsPar e) -- nlHsIf should generate if-expressions which are NOT subject to @@ -608,7 +618,7 @@ nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs nlHsIf cond true false = noLocA (HsIf noAnn cond true false) nlHsCase expr matches - = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches))) + = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion) (noLocA matches))) nlList exprs = noLocA (ExplicitList noAnn exprs) nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) @@ -867,7 +877,7 @@ spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr - = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun) + = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion) (L (noAnnSrcSpan loc) fun) [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr emptyLocalBinds] ===================================== compiler/GHC/HsToCore/Arrows.hs ===================================== @@ -811,7 +811,7 @@ dsCases ids local_vars stack_id stack_ty res_ty Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$> dsExpr (HsLamCase EpAnnNotUsed LamCase (MG { mg_alts = noLocA [] - , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty Generated + , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated OtherExpansion) })) -- Replace the commands in the case with these tagged tuples, ===================================== compiler/GHC/HsToCore/Docs.hs ===================================== @@ -346,10 +346,10 @@ subordinates env instMap decl = case decl of data_fams = do DataFamInstDecl { dfid_eqn = (FamEqn { feqn_tycon = L l _ - , feqn_rhs = defn } :: FamEqn GhcRn (HsDataDefn GhcRn))} <- unLoc <$> cid_datafam_insts d + , feqn_rhs = defn })} <- unLoc <$> cid_datafam_insts d [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn ty_fams = do - TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ } :: FamEqn GhcRn (LHsType GhcRn)) } <- unLoc <$> cid_tyfam_insts d + TyFamInstDecl { tfid_eqn = (FamEqn { feqn_tycon = L l _ }) } <- unLoc <$> cid_tyfam_insts d [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] in data_fams ++ ty_fams ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -763,7 +763,7 @@ dsDo ctx stmts (MG { mg_alts = noLocA [mkSimpleMatch LambdaExpr [mfix_pat] body] - , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated + , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty (Generated OtherExpansion) }) mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats body = noLocA $ HsDo body_ty ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -831,10 +831,10 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches' $ replicate (length (grhssGRHSs m)) initNablas is_pat_syn_match :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool - is_pat_syn_match Generated (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat + is_pat_syn_match (Generated _) (L _ (Match _ _ [l_pat] _)) = isPatSyn l_pat is_pat_syn_match _ _ = False non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool - non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False + non_wc (Generated _) (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False non_wc _ _ = True matchEquations :: HsMatchContext GhcRn ===================================== compiler/GHC/HsToCore/Match/Constructor.hs ===================================== @@ -20,7 +20,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import GHC.Hs import GHC.HsToCore.Binds import GHC.Core.ConLike -import GHC.Types.Basic ( Origin(..) ) +import GHC.Types.Basic ( Origin(..), GenReason (..) ) import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity import GHC.HsToCore.Monad @@ -167,7 +167,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct return ( wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) . mkCoreLets ds_bind - , eqn { eqn_orig = Generated + , eqn { eqn_orig = Generated OtherExpansion , eqn_pats = conArgPats val_arg_tys args ++ pats } ) shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) ===================================== compiler/GHC/HsToCore/Pmc/Utils.hs ===================================== @@ -14,7 +14,7 @@ module GHC.HsToCore.Pmc.Utils ( import GHC.Prelude -import GHC.Types.Basic (Origin(..), isGenerated) +import GHC.Types.Basic (Origin(..), isGenerated, isDoExpansionGenerated) import GHC.Driver.Session import GHC.Hs import GHC.Core.Type @@ -109,7 +109,7 @@ arrowMatchContextExhaustiveWarningFlag = \ case -- exhaustiveness check). isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool isMatchContextPmChecked _ origin LambdaExpr -- It is likely that this is generated by expanding do stmts - = isGenerated origin + = isDoExpansionGenerated origin isMatchContextPmChecked dflags origin kind | isGenerated origin = False ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -906,7 +906,7 @@ instance ( HiePass p setOrigin :: Origin -> NodeOrigin -> NodeOrigin setOrigin FromSource _ = SourceInfo -setOrigin Generated _ = GeneratedInfo +setOrigin (Generated _) _ = GeneratedInfo instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where toHie (L sp psb) = concatM $ case psb of ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -55,7 +55,7 @@ import GHC.Types.SourceText ( SourceText(..), IntegralLit ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated) ) +import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated), GenReason (OtherExpansion) ) import GHC.Data.List.SetOps ( removeDupsOn ) import GHC.Data.Maybe ( whenIsJust ) import GHC.Driver.Session @@ -715,6 +715,6 @@ genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn genFunBind fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup Generated (wrapGenSpan ms) + , fun_matches = mkMatchGroup (Generated OtherExpansion) (wrapGenSpan ms) , fun_ext = emptyNameSet } ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -2301,7 +2301,7 @@ mkFunBindSE arity loc fun pats_and_exprs mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches - = L (na2la loc) (mkFunBind Generated fun matches) + = L (na2la loc) (mkFunBind (Generated OtherExpansion) fun matches) -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last @@ -2329,7 +2329,7 @@ mkRdrFunBindEC :: Arity -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches - = L (na2la loc) (mkFunBind Generated fun matches') + = L (na2la loc) (mkFunBind (Generated OtherExpansion) fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {} @@ -2353,7 +2353,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches mkRdrFunBindSE :: Arity -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindSE arity fun@(L loc fun_rdr) matches - = L (na2la loc) (mkFunBind Generated fun matches') + = L (na2la loc) (mkFunBind (Generated OtherExpansion) fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare" ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -1276,7 +1276,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr) case_expr :: HsExpr GhcRn - case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches)) + case_expr = HsCase noExtField record_expr (mkMatchGroup (Generated OtherExpansion) (wrapGenSpan matches)) matches :: [LMatch GhcRn (LHsExpr GhcRn)] matches = map make_pat relevant_cons ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -79,7 +79,7 @@ import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Id import GHC.Types.SrcLoc -import GHC.Types.Basic (Origin (..)) +import GHC.Types.Basic (Origin (..), GenReason (..)) import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -1256,7 +1256,7 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts) expand_stmts <- expand_do_stmts do_or_lc lstmts return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=) [ e - , mkHsLam [pat] (noLocA $ PopSrcSpan expand_stmts) -- (\ x -> stmts') + , mkHsLamDoExp [pat] (noLocA $ PopSrcSpan expand_stmts) -- (\ x -> stmts') ] expand_do_stmts do_or_lc (L _ (LetStmt _ bnds) : lstmts) = @@ -1298,7 +1298,7 @@ expand_do_stmts do_or_lc do expand_stmts <- expand_do_stmts do_or_lc lstmts return $ mkHsApps (genLHsVar bindMName) -- (Prelude.>>=) [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block)) - , mkHsLam [ mkBigLHsVarPatTup all_ids ] -- (\ x -> + , mkHsLamDoExp [ mkBigLHsVarPatTup all_ids ] -- (\ x -> (noLocA $ PopSrcSpan expand_stmts) -- stmts') ] where @@ -1316,7 +1316,7 @@ expand_do_stmts do_or_lc do_block :: LHsExpr GhcRn do_block = wrapGenSpan $ HsDo noExtField (DoExpr Nothing) $ do_stmts mfix_expr :: LHsExpr GhcRn - mfix_expr = mkHsLam [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block + mfix_expr = mkHsLamDoExp [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block -- LazyPat becuase we do not want to eagerly evaluate the pattern -- and potentially loop forever @@ -1391,7 +1391,7 @@ mk_failable_lexpr_tcm pat lexpr fail_op = ; if b -- don't decorate with fail statement if -- 1) the pattern is irrefutable - then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr)) + then return $ mkHsLamDoExp [pat] (noLocA (PopSrcSpan lexpr)) else mk_fail_lexpr pat lexpr fail_op } @@ -1401,7 +1401,7 @@ mk_failable_lexpr_tcm pat lexpr fail_op = mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn) mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) = do dflags <- getDynFlags - return $ noLocA (HsLam noExtField $ mkMatchGroup Generated -- \ + return $ noLocA (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \ (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) -- pat -> expr , mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern" (noLocA $ genHsApp fail_op ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1623,8 +1623,9 @@ checkGADT conlike ex_tvs arg_tys = \case has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs -- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on type checking +-- does depend on the type environment however isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> TcM Bool -isIrrefutableHsPatRn _ is_strict pat = +isIrrefutableHsPatRn tc_env is_strict pat = do traceTc "isIrrefutableHsPatRn" empty goL pat where @@ -1662,9 +1663,7 @@ isIrrefutableHsPatRn _ is_strict pat = ; traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon , ppr (isNewTyCon tycon) , ppr (tcHasFixedRuntimeRep tycon)]) - ; let b' = (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon - || tcHasFixedRuntimeRep tycon) + ; let b' = isJust (tyConSingleDataCon_maybe tycon) ; return (b && b') } id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id) (AConLike cl) -> @@ -1676,9 +1675,7 @@ isIrrefutableHsPatRn _ is_strict pat = traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon , ppr (isNewTyCon tycon) , ppr (tcHasFixedRuntimeRep tycon)] ) - let b' = (isJust (tyConSingleDataCon_maybe tycon) - || isNewTyCon tycon - || tcHasFixedRuntimeRep tycon) + let b' = isJust (tyConSingleDataCon_maybe tycon) return (b && b') PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con) return False -- conservative ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1961,7 +1961,7 @@ lookupName is_type_name s getThSpliceOrigin :: TcM Origin getThSpliceOrigin = do warn <- goptM Opt_EnableThSpliceWarnings - if warn then return FromSource else return Generated + if warn then return FromSource else return (Generated OtherExpansion) getThing :: TH.Name -> TcM TcTyThing ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -2166,7 +2166,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name , tyConBinderForAllTyFlag tcb /= Inferred ] rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys bind = L (noAnnSrcSpan loc) - $ mkTopFunBind Generated fn + $ mkTopFunBind (Generated OtherExpansion) fn [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body" @@ -2410,4 +2410,3 @@ instDeclCtxt2 dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = hang (text "In the instance declaration for") 2 (quotes doc) - ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -811,13 +811,13 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ MG{ mg_alts = L (l2l $ getLoc lpat) cases - , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated + , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty (Generated OtherExpansion) } body' = noLocA $ HsLam noExtField $ MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr args body] - , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated + , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty (Generated OtherExpansion) } match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) [] (mkHsLams (rr_tv:res_tv:univ_tvs) @@ -825,7 +825,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn (EmptyLocalBinds noExtField) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (l2l $ getLoc match) [match] - , mg_ext = MatchGroupTc [] res_ty Generated + , mg_ext = MatchGroupTc [] res_ty (Generated OtherExpansion) } matcher_arity = length req_theta + 3 -- See Note [Pragmas for pattern synonyms] @@ -958,7 +958,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated (noLocA [builder_match]) + mk_mg body = mkMatchGroup (Generated OtherExpansion) (noLocA [builder_match]) where builder_args = [L (na2la loc) (VarPat noExtField (L loc n)) | L loc n <- args] ===================================== compiler/GHC/Tc/TyCl/Utils.hs ===================================== @@ -928,7 +928,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel -- make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x -- where cons_w_field = [C2,C7] - sel_bind = mkTopFunBind Generated sel_lname alts + sel_bind = mkTopFunBind (Generated OtherExpansion) sel_lname alts where alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) [] unit_rhs] ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -35,7 +35,8 @@ module GHC.Types.Basic ( FunctionOrData(..), RecFlag(..), isRec, isNonRec, boolToRecFlag, - Origin(..), isGenerated, + Origin(..), isGenerated, isDoExpansionGenerated, + GenReason(..), RuleName, pprRuleName, @@ -582,17 +583,29 @@ instance Binary RecFlag where ************************************************************************ -} +data GenReason = DoExpansion + | OtherExpansion + deriving (Eq, Data) + +instance Outputable GenReason where + ppr DoExpansion = text "DoExpansion" + ppr OtherExpansion = text "OtherExpansion" + data Origin = FromSource - | Generated + | Generated GenReason deriving( Eq, Data ) isGenerated :: Origin -> Bool -isGenerated Generated = True +isGenerated (Generated _) = True isGenerated FromSource = False +isDoExpansionGenerated :: Origin -> Bool +isDoExpansionGenerated (Generated DoExpansion) = True +isDoExpansionGenerated _ = False + instance Outputable Origin where ppr FromSource = text "FromSource" - ppr Generated = text "Generated" + ppr (Generated r) = text "Generated" <+> ppr r {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36c56e5c25e0e95d1e155e96e324e109cadfcef0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36c56e5c25e0e95d1e155e96e324e109cadfcef0 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 08:24:42 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Mon, 08 May 2023 04:24:42 -0400 Subject: [Git][ghc/ghc][wip/T23307] 9 commits: Add structured error messages for GHC.Rename.Utils Message-ID: <6458b1ca3ea5_38ffda2c8eaf54195596@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23307 at Glasgow Haskell Compiler / GHC Commits: 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 00330bbc by Simon Peyton Jones at 2023-05-08T09:26:37+01:00 Make GHC.Types.Id.Make.shouldUnpackTy a bit more clever As #23307, GHC.Types.Id.Make.shouldUnpackTy was leaving money on the table, failing to unpack arguments that are perfectly unpackable. The fix is pretty easy; see Note [Recursive unboxing] - - - - - 30 changed files: - .gitlab-ci.yml - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Make.hs - docs/users_guide/exts/ffi.rst - docs/users_guide/using-warnings.rst - ghc/Main.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/deSugar/should_compile/ds053.stderr - testsuite/tests/deriving/should_compile/T13919.stderr - testsuite/tests/driver/t22391/t22391.stderr - testsuite/tests/driver/t22391/t22391j.stderr - testsuite/tests/driver/werror.stderr - testsuite/tests/gadt/T12087.stderr - testsuite/tests/gadt/T14320.stderr - testsuite/tests/gadt/T16427.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f2f015689111c7a321063ddce403ba8ddf35b76a...00330bbc4058187033c1f0d989c09b2c807e84da -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f2f015689111c7a321063ddce403ba8ddf35b76a...00330bbc4058187033c1f0d989c09b2c807e84da You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 09:27:22 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 05:27:22 -0400 Subject: [Git][ghc/ghc][wip/T23146] 17 commits: Add structured error messages for GHC.Rename.Utils Message-ID: <6458c07a156c_38ffda30f8e79423021d@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - cf76eca0 by Ben Gamari at 2023-05-08T10:27:00+01:00 testsuite: Add tests for #23146 Both lifted and unlifted variants. - - - - - 96bdef3a by Ben Gamari at 2023-05-08T10:27:00+01:00 codeGen: Fix some Haddocks - - - - - 8adcf90e by Ben Gamari at 2023-05-08T10:27:00+01:00 codeGen: Give proper LFInfo to datacon wrappers As noted in `Note [Conveying CAF-info and LFInfo between modules]`, when importing a binding from another module we must ensure that it gets the appropriate `LambdaFormInfo` if it is in WHNF to ensure that references to it are tagged correctly. However, the implementation responsible for doing this, `GHC.StgToCmm.Closure.mkLFImported`, only dealt with datacon workers and not wrappers. This lead to the crash of this program in #23146: module B where type NP :: [UnliftedType] -> UnliftedType data NP xs where UNil :: NP '[] module A where import B fieldsSam :: NP xs -> NP xs -> Bool fieldsSam UNil UNil = True x = fieldsSam UNil UNil Due to its GADT nature, `UNil` produces a trivial wrapper $WUNil :: NP '[] $WUNil = UNil @'[] @~(<co:1>) which is referenced in the RHS of `A.x`. Due to the above-mentioned bug in `mkLFImported`, the references to `$WUNil` passed to `fieldsSam` were not tagged. This is problematic as `fieldsSam` expected its arguments to be tagged as they are unlifted. The fix is straightforward: extend the logic in `mkLFImported` to cover (nullary) datacon wrappers as well as workers. This is safe because we know that the wrapper of a nullary datacon will be in WHNF, even if it includes equalities evidence (since such equalities are not runtime relevant). Thanks to @MangoIV for the great ticket and @alt-romes for his minimization and help debugging. Fixes #23146. - - - - - 3c6d972e by Rodrigo Mesquita at 2023-05-08T10:27:00+01:00 codeGen: Fix LFInfo of imported datacon wrappers As noted in #23231 and in the previous commit, we were failing to give a an LFInfo of LFCon to a nullary datacon wrapper from another module, failing to properly tag pointers which ultimately led to the segmentation fault in #23146. On top of the previous commit which now considers wrappers where we previously only considered workers, we change the order of the guards so that we check for the arity of the binding before we check whether it is a constructor. This allows us to (1) Correctly assign `LFReEntrant` to imported wrappers whose worker was nullary, which we previously would fail to do (2) Remove the `isNullaryRepDataCon` predicate: (a) which was previously wrong, since it considered wrappers whose workers had zero-width arguments to be non-nullary and would fail to give `LFCon` to them (b) is now unnecessary, since arity == 0 guarantees - that the worker takes no arguments at all - and the wrapper takes no arguments and its RHS must be an application of the worker to zero-width-args only. - we lint these two items with an assertion that the datacon `hasNoNonZeroWidthArgs` We also update `isTagged` to use the new logic in determining the LFInfos of imported Ids. The creation of LFInfos for imported Ids and this detail are explained in Note [The LFInfo of Imported Ids]. Note that before the patch to those issues we would already consider these nullary wrappers to have `LFCon` lambda form info; but failed to re-construct that information in `mkLFImported` Closes #23231, #23146 (I've additionally batched some fixes to documentation I found while investigating this issue) - - - - - 31a7c8ba by Rodrigo Mesquita at 2023-05-08T10:27:00+01:00 Make LFInfos for DataCons on construction As a result of the discussion in !10165, we decided to amend the previous commit which fixed the logic of `mkLFImported` with regard to datacon workers and wrappers. Instead of having the logic for the LFInfo of datacons be in `mkLFImported`, we now construct an LFInfo for all data constructors on GHC.Types.Id.Make and store it in the `lfInfo` field. See the new Note [LFInfo of DataCon workers and wrappers] and ammendments to Note [The LFInfo of Imported Ids] - - - - - 497895f2 by Rodrigo Mesquita at 2023-05-08T10:27:00+01:00 Update Note [Core letrec invariant] Authored by @simonpj - - - - - b263dd1b by Rodrigo Mesquita at 2023-05-08T10:27:00+01:00 Rename mkLFImported to importedIdLFInfo The `mkLFImported` sounded too much like a constructor of sorts, when really it got the `LFInfo` of an imported Id from its `lf_info` field when this existed, and otherwise returned a conservative estimate of that imported Id's LFInfo. This in contrast to functions such as `mkLFReEntrant` which really are about constructing an `LFInfo`. - - - - - 9cea6c86 by Rodrigo Mesquita at 2023-05-08T10:27:00+01:00 Enforce invariant on typePrimRepArgs in the types As part of the documentation effort in !10165 I came across this invariant on 'typePrimRepArgs' which is easily expressed at the type-level through a NonEmpty list. It allowed us to remove one panic. - - - - - 43b82817 by Rodrigo Mesquita at 2023-05-08T10:27:00+01:00 Merge outdated Note [Data con representation] into Note [Data constructor representation] Introduce new Note [Constructor applications in STG] to better support the merge, and reference it from the relevant bits in the STG syntax. - - - - - 30 changed files: - .gitlab-ci.yml - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToCmm/Types.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c77f81c87e43b1dd1d34d7c928b323b675cab8c5...43b828178afb8eea69db223181fe2cc70f72a642 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c77f81c87e43b1dd1d34d7c928b323b675cab8c5...43b828178afb8eea69db223181fe2cc70f72a642 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 09:28:49 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 05:28:49 -0400 Subject: [Git][ghc/ghc][wip/T23146] 4 commits: Update Note [Core letrec invariant] Message-ID: <6458c0d151cb0_38ffda31907190231885@gitlab.mail> Rodrigo Mesquita pushed to branch wip/T23146 at Glasgow Haskell Compiler / GHC Commits: c7160662 by Rodrigo Mesquita at 2023-05-08T10:28:33+01:00 Update Note [Core letrec invariant] Authored by @simonpj - - - - - ab848cfd by Rodrigo Mesquita at 2023-05-08T10:28:36+01:00 Rename mkLFImported to importedIdLFInfo The `mkLFImported` sounded too much like a constructor of sorts, when really it got the `LFInfo` of an imported Id from its `lf_info` field when this existed, and otherwise returned a conservative estimate of that imported Id's LFInfo. This in contrast to functions such as `mkLFReEntrant` which really are about constructing an `LFInfo`. - - - - - a4f4b294 by Rodrigo Mesquita at 2023-05-08T10:28:36+01:00 Enforce invariant on typePrimRepArgs in the types As part of the documentation effort in !10165 I came across this invariant on 'typePrimRepArgs' which is easily expressed at the type-level through a NonEmpty list. It allowed us to remove one panic. - - - - - 14358f34 by Rodrigo Mesquita at 2023-05-08T10:28:36+01:00 Merge outdated Note [Data con representation] into Note [Data constructor representation] Introduce new Note [Constructor applications in STG] to better support the merge, and reference it from the relevant bits in the STG syntax. - - - - - 10 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Types.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -368,18 +368,37 @@ Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Core letrec invariant: - The right hand sides of all - /top-level/ or /recursive/ - bindings must be of lifted type - - There is one exception to this rule, top-level @let at s are - allowed to bind primitive string literals: see - Note [Core top-level string literals]. + The right hand sides of all /top-level/ or /recursive/ + bindings must be of lifted type See "Type#type_classification" in GHC.Core.Type -for the meaning of "lifted" vs. "unlifted"). - -For the non-top-level, non-recursive case see Note [Core let-can-float invariant]. +for the meaning of "lifted" vs. "unlifted". + +For the non-top-level, non-recursive case see +Note [Core let-can-float invariant]. + +At top level, however, there are two exceptions to this rule: + +(TL1) A top-level binding is allowed to bind primitive string literal, + (which is unlifted). See Note [Core top-level string literals]. + +(TL2) In Core, we generate a top-level binding for every non-newtype data +constructor worker or wrapper + e.g. data T = MkT Int + we generate + MkT :: Int -> T + MkT = \x. MkT x + (This binding looks recursive, but isn't; it defines a top-level, curried + function whose body just allocates and returns the data constructor.) + + But if (a) the data contructor is nullary and (b) the data type is unlifted, + this binding is unlifted. + e.g. data S :: UnliftedType where { S1 :: S, S2 :: S -> S } + we generate + S1 :: S -- A top-level unlifted binding + S1 = S1 + We allow this top-level unlifted binding to exist, after CorePrep + only. Note [Core let-can-float invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -141,7 +141,19 @@ becomes case e of { T a' b -> let a = I# a' in ... } To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. +differently, as follows in Note [Data Constructor Naming]. + +The `dcRepType` field of a `DataCon` contains the type of the representation of +the constructor /worker/, also called the Core representation. + +The Core representation may differ from the type of the constructor /wrapper/ +(built by `mkDataConRep`). Besides unpacking (as seen in the example above), +dictionaries and coercions become explict arguments in the Core representation +of a constructor. + +Note that this representation is still *different* from runtime +representation. (Which is what STG uses after unarise). +See Note [Constructor applications in STG] in GHC.Stg.Syntax. Note [Data Constructor Naming] @@ -209,7 +221,8 @@ Note [Data constructor workers and wrappers] * See Note [Data Constructor Naming] for how the worker and wrapper are named -* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments +* The workers don't take the dcStupidTheta dicts as arguments, while the + wrappers currently do * The wrapper (if it exists) takes dcOrigArgTys as its arguments. The worker takes dataConRepArgTys as its arguments @@ -528,7 +541,7 @@ data DataCon -- forall a x y. (a~(x,y), x~y, Ord x) => -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) + -- see Note [Data constructor representation]) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: -- case (e :: T t) of @@ -988,51 +1001,6 @@ we consult HsImplBang: The boolean flag is used only for this warning. See #11270 for motivation. -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -So whenever this module talks about the representation of a data constructor -what it means is the DataCon with all Unpacking having been applied. -We can think of this as the Core representation. - -Here's an example illustrating the Core representation: - data Ord a => T a = MkT Int! a Void# -Here - T :: Ord a => Int -> a -> Void# -> T a -but the rep type is - Trep :: Int# -> a -> Void# -> T a -Actually, the unboxed part isn't implemented yet! - -Note that this representation is still *different* from runtime -representation. (Which is what STG uses after unarise). - -This is how T would end up being used in STG post-unarise: - - let x = T 1# y - in ... - case x of - T int a -> ... - -The Void# argument is dropped and the boxed int is replaced by an unboxed -one. In essence we only generate binders for runtime relevant values. - -We also flatten out unboxed tuples in this process. See the unarise -pass for details on how this is done. But as an example consider -`data S = MkS Bool (# Bool | Char #)` which when matched on would -result in an alternative with three binders like this - - MkS bool tag tpl_field -> - -See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] -for the details of this transformation. - ************************************************************************ * * ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -889,12 +889,12 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise = case typePrimRepArgs ty of - [rep_ty] -> do + rep_ty :| [] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys + rep_ty :| rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -36,7 +36,7 @@ import GHC.Core ( AltCon(..) ) import GHC.Core.Type import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (mkLFImported) +import GHC.StgToCmm.Closure (importedIdLFInfo) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -275,7 +275,7 @@ isTagged v = do False -> return $! -- Determine whether it is tagged from the LFInfo of the imported id. -- See Note [The LFInfo of Imported Ids] - case mkLFImported v of + case importedIdLFInfo v of -- Function, applied not entered. LFReEntrant {} -> True ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -237,6 +237,52 @@ StgConApp and StgPrimApp --- saturated applications There are specialised forms of application, for constructors, primitives, and literals. + +Note [Constructor applications in STG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After the unarisation pass: +* In `StgConApp` and `StgRhsCon` and `StgAlt` we filter out the void arguments, + leaving only non-void ones. +* In `StgApp` and `StgOpApp` we retain void arguments. + +We can do this because we know that `StgConApp` and `StgRhsCon` are saturated applications, +so we lose no information by dropping those void args. In contrast, in `StgApp` we need the + void argument to compare the number of args in the call with the arity of the function. + +This is an open design choice. We could instead choose to treat all these applications +consistently (keeping the void args). But for some reason we don't, and this Note simply +documents that design choice. + +As an example, consider: + + data T a = MkT Int! a Void# + +The wrapper's representation and the worker's representation (i.e. the +datacon's Core representation) are respectively: + + $WT :: Int -> a -> Void# -> T a + T :: Int# -> a -> Void# -> T a + +T would end up being used in STG post-unarise as: + + let x = T 1# y + in ... + case x of + T int a -> ... + +The Void# argument is dropped. In essence we only generate binders for runtime +relevant values. + +We also flatten out unboxed tuples in this process. See the unarise +pass for details on how this is done. But as an example consider +`data S = MkS Bool (# Bool | Char #)` which when matched on would +result in an alternative with three binders like this + + MkS bool tag tpl_field -> + +See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] +for the details of this transformation. + -} | StgLit Literal @@ -245,7 +291,7 @@ literals. -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) + [StgArg] -- Saturated. See Note [Constructor applications in STG] [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call @@ -422,7 +468,7 @@ important): -- are not allocated. ConstructorNumber [StgTickish] - [StgArg] -- Args + [StgArg] -- Saturated Args. See Note [Constructor applications in STG] Type -- Type, for rewriting to an StgRhsClosure -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -81,8 +81,10 @@ import Data.Coerce (coerce) import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap +import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -296,8 +298,8 @@ argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: [ArgRep] -> [ArgRep] -non_void = filter nv +non_void :: NonEmpty ArgRep -> [ArgRep] +non_void = NE.filter nv where nv V = False nv _ = True @@ -464,7 +466,7 @@ returnUnliftedAtom d s p e = do StgLitArg lit -> typePrimRepArgs (literalType lit) StgVarArg i -> bcIdPrimReps i (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb reps + ret <- returnUnliftedReps d s szb (NE.toList $! reps) return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -867,7 +869,7 @@ doCase d s p scrut bndr alts (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -1660,9 +1662,8 @@ maybe_getCCallReturnRep fn_ty (pprType fn_ty) in case r_reps of - [] -> panic "empty typePrimRepArgs" - [VoidRep] -> Nothing - [rep] -> Just rep + VoidRep :| [] -> Nothing + rep :| [] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -2117,7 +2118,7 @@ idSizeCon platform var isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - bcIdPrimReps $ var + NE.toList . bcIdPrimReps $ var | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) bcIdArgRep :: Platform -> Id -> ArgRep @@ -2125,13 +2126,13 @@ bcIdArgRep platform = toArgRep platform . bcIdPrimRep bcIdPrimRep :: Id -> PrimRep bcIdPrimRep id - | [rep] <- typePrimRepArgs (idType id) + | rep :| [] <- typePrimRepArgs (idType id) = rep | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) -bcIdPrimReps :: Id -> [PrimRep] +bcIdPrimReps :: Id -> NonEmpty PrimRep bcIdPrimReps id = typePrimRepArgs (idType id) repSizeWords :: Platform -> PrimRep -> WordOff @@ -2189,8 +2190,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e) mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> [ArgRep] -typeArgReps platform = map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> NonEmpty ArgRep +typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs -- ----------------------------------------------------------------------------- -- The bytecode generator's monad ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -28,7 +28,7 @@ module GHC.StgToCmm.Closure ( LambdaFormInfo, -- Abstract StandardFormInfo, -- ...ditto... mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + mkApLFInfo, importedIdLFInfo, mkLFArgument, mkLFLetNoEscape, mkLFStringLit, lfDynTag, isLFThunk, isLFReEntrant, lfUpdatable, @@ -256,10 +256,10 @@ mkApLFInfo id upd_flag arity (mightBeFunTy (idType id)) ------------- --- | Make a 'LambdaFormInfo' for an imported Id. +-- | The 'LambdaFormInfo' of an imported Id. -- See Note [The LFInfo of Imported Ids] -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id = +importedIdLFInfo :: Id -> LambdaFormInfo +importedIdLFInfo id = -- See Note [Conveying CAF-info and LFInfo between modules] in -- GHC.StgToCmm.Types case idLFInfo_maybe id of @@ -305,7 +305,7 @@ In particular, saturated data constructor applications *must* be unambiguously given `LFCon`, and if the LFInfo says LFCon, then it really is a static data constructor, and similar for LFReEntrant. -In `mkLFImported`, we construct a LambdaFormInfo for imported Ids as follows: +In `importedIdLFInfo`, we construct a LambdaFormInfo for imported Ids as follows: (1) If the `lfInfo` field contains an LFInfo, we use that LFInfo which is correct by construction (the invariant being that if it exists, it is correct): ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -149,7 +149,7 @@ getCgIdInfo id | otherwise = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) in return $ - litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) + litIdInfo platform id (importedIdLFInfo id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug, id is neither in local binds nor is external }}} ===================================== compiler/GHC/StgToCmm/Types.hs ===================================== @@ -53,7 +53,7 @@ make a conservative assumption, but that is bad: e.g. #16559, #15155, and wiki: commentary/rts/haskell-execution/pointer-tagging Conservative assumption here is made when we import an Id without a - LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.mkLFImported. + LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.importedIdLFInfo. So we arrange to always serialise this information into the interface file. The moving parts are: ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -84,12 +84,11 @@ isNvUnaryType ty = False -- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> [PrimRep] +typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep typePrimRepArgs ty - | [] <- reps - = [VoidRep] - | otherwise - = reps + = case reps of + [] -> VoidRep :| [] + (x:xs) -> x :| xs where reps = typePrimRep ty View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/43b828178afb8eea69db223181fe2cc70f72a642...14358f34c34c27d20cc5b676e0b62a069a45d40f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/43b828178afb8eea69db223181fe2cc70f72a642...14358f34c34c27d20cc5b676e0b62a069a45d40f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 10:06:37 2023 From: gitlab at gitlab.haskell.org (Cheng Shao (@TerrorJack)) Date: Mon, 08 May 2023 06:06:37 -0400 Subject: [Git][ghc/ghc][wip/T22756] 384 commits: Refresh profiling docs Message-ID: <6458c9ada44e0_38ffda354f8d20264960@gitlab.mail> Cheng Shao pushed to branch wip/T22756 at Glasgow Haskell Compiler / GHC Commits: 1e9eac1c by Matthew Pickering at 2023-02-13T11:36:41+01:00 Refresh profiling docs I went through the whole of the profiling docs and tried to amend them to reflect current best practices and tooling. In particular I removed some old references to tools such as hp2any and replaced them with references to eventlog2html. - - - - - da208b9a by Matthew Pickering at 2023-02-13T11:36:41+01:00 docs: Add section about profiling and foreign calls Previously there was no documentation for how foreign calls interacted with the profiler. This can be quite confusing for users so getting it into the user guide is the first step to a potentially better solution. See the ticket for more insightful discussion. Fixes #21764 - - - - - 081640f1 by Bodigrim at 2023-02-13T12:51:52-05:00 Document that -fproc-alignment was introduced only in GHC 8.6 - - - - - 16adc349 by Sven Tennie at 2023-02-14T11:26:31-05:00 Add clangd flag to include generated header files This enables clangd to correctly check C files that import Rts.h. (The added include directory contains ghcautoconf.h et. al.) - - - - - c399ccd9 by amesgen at 2023-02-14T11:27:14-05:00 Mention new `Foreign.Marshal.Pool` implementation in User's Guide - - - - - b9282cf7 by Ben Gamari at 2023-02-14T11:27:50-05:00 upload_ghc_libs: More control over which packages to operate on Here we add a `--skip` flag to `upload_ghc_libs`, making it easier to limit which packages to upload. This is often necessary when one package is not uploadable (e.g. see #22740). - - - - - aa3a262d by PHO at 2023-02-14T11:28:29-05:00 Assume platforms support rpaths if they use either ELF or Mach-O Not only Linux, Darwin, and FreeBSD support rpaths. Determine the usability of rpaths based on the object format, not on OS. - - - - - 47716024 by PHO at 2023-02-14T11:29:09-05:00 RTS linker: Improve compatibility with NetBSD 1. Hint address to NetBSD mmap(2) has a different semantics from that of Linux. When a hint address is provided, mmap(2) searches for a free region at or below the hint but *never* above it. This means we can't reliably search for free regions incrementally on the userland, especially when ASLR is enabled. Let the kernel do it for us if we don't care where the mapped address is going to be. 2. NetBSD not only hates to map pages as rwx, but also disallows to switch pages from rw- to r-x unless the intention is declared when pages are initially requested. This means we need a new MemoryAccess mode for pages that are going to be changed to r-x. - - - - - 11de324a by Li-yao Xia at 2023-02-14T11:29:49-05:00 base: Move changelog entry to its place - - - - - 75930424 by Ben Gamari at 2023-02-14T11:30:27-05:00 nativeGen/AArch64: Emit Atomic{Read,Write} inline Previously the AtomicRead and AtomicWrite operations were emitted as out-of-line calls. However, these tend to be very important for performance, especially the RELAXED case (which only exists for ThreadSanitizer checking). Fixes #22115. - - - - - d6411d6c by Andreas Klebinger at 2023-02-14T11:31:04-05:00 Fix some correctness issues around tag inference when targeting the bytecode generator. * Let binders are now always assumed untagged for bytecode. * Imported referenced are now always assumed to be untagged for bytecode. Fixes #22840 - - - - - 9fb4ca89 by sheaf at 2023-02-14T11:31:49-05:00 Introduce warning for loopy superclass solve Commit aed1974e completely re-engineered the treatment of loopy superclass dictionaries in instance declarations. Unfortunately, it has the potential to break (albeit in a rather minor way) user code. To alleviate migration concerns, this commit re-introduces the old behaviour. Any reliance on this old behaviour triggers a warning, controlled by `-Wloopy-superclass-solve`. The warning text explains that GHC might produce bottoming evidence, and provides a migration strategy. This allows us to provide a graceful migration period, alerting users when they are relying on this unsound behaviour. Fixes #22912 #22891 #20666 #22894 #22905 - - - - - 1928c7f3 by Cheng Shao at 2023-02-14T11:32:26-05:00 rts: make it possible to change mblock size on 32-bit targets The MBLOCK_SHIFT macro must be the single source of truth for defining the mblock size, and changing it should only affect performance, not correctness. This patch makes it truly possible to reconfigure mblock size, at least on 32-bit targets, by fixing places which implicitly relied on the previous MBLOCK_SHIFT constant. Fixes #22901. - - - - - 78aa3b39 by Simon Hengel at 2023-02-14T11:33:06-05:00 Update outdated references to notes - - - - - e8baecd2 by meooow25 at 2023-02-14T11:33:49-05:00 Documentation: Improve Foldable1 documentation * Explain foldrMap1, foldlMap1, foldlMap1', and foldrMap1' in greater detail, the text is mostly adapted from documentation of Foldable. * Describe foldr1, foldl1, foldl1' and foldr1' in terms of the above functions instead of redoing the full explanation. * Small updates to documentation of fold1, foldMap1 and toNonEmpty, again adapting from Foldable. * Update the foldMap1 example to lists instead of Sum since this is recommended for lazy right-associative folds. Fixes #22847 - - - - - 85a1a575 by romes at 2023-02-14T11:34:25-05:00 fix: Mark ghci Prelude import as implicit Fixes #22829 In GHCi, we were creating an import declaration for Prelude but we were not setting it as an implicit declaration. Therefore, ghci's import of Prelude triggered -Wmissing-import-lists. Adds regression test T22829 to testsuite - - - - - 3b019a7a by Cheng Shao at 2023-02-14T11:35:03-05:00 compiler: fix generateCgIPEStub for no-tables-next-to-code builds generateCgIPEStub already correctly implements the CmmTick finding logic for when tables-next-to-code is on/off, but it used the wrong predicate to decide when to switch between the two. Previously it switches based on whether the codegen is unregisterised, but there do exist registerised builds that disable tables-next-to-code! This patch corrects that problem. Fixes #22896. - - - - - 08c0822c by doyougnu at 2023-02-15T00:16:39-05:00 docs: release notes, user guide: add js backend Follow up from #21078 - - - - - 79d8fd65 by Bryan Richter at 2023-02-15T00:17:15-05:00 Allow failure in nightly-x86_64-linux-deb10-no_tntc-validate See #22343 - - - - - 9ca51f9e by Cheng Shao at 2023-02-15T00:17:53-05:00 rts: add the rts_clearMemory function This patch adds the rts_clearMemory function that does its best to zero out unused RTS memory for a wasm backend use case. See the comment above rts_clearMemory() prototype declaration for more detailed explanation. Closes #22920. - - - - - 26df73fb by Oleg Grenrus at 2023-02-15T22:20:57-05:00 Add -single-threaded flag to force single threaded rts This is the small part of implementing https://github.com/ghc-proposals/ghc-proposals/pull/240 - - - - - 631c6c72 by Cheng Shao at 2023-02-16T06:43:09-05:00 docs: add a section for the wasm backend Fixes #22658 - - - - - 1878e0bd by Bryan Richter at 2023-02-16T06:43:47-05:00 tests: Mark T12903 fragile everywhere See #21184 - - - - - b9420eac by Bryan Richter at 2023-02-16T06:43:47-05:00 Mark all T5435 variants as fragile See #22970. - - - - - df3d94bd by Sylvain Henry at 2023-02-16T06:44:33-05:00 Testsuite: mark T13167 as fragile for JS (#22921) - - - - - 324e925b by Sylvain Henry at 2023-02-16T06:45:15-05:00 JS: disable debugging info for heap objects - - - - - 518af814 by Josh Meredith at 2023-02-16T10:16:32-05:00 Factor JS Rts generation for h$c{_,0,1,2} into h$c{n} and improve name caching - - - - - 34cd308e by Ben Gamari at 2023-02-16T10:17:08-05:00 base: Note move of GHC.Stack.CCS.whereFrom to GHC.InfoProv in changelog Fixes #22883. - - - - - 12965aba by Simon Peyton Jones at 2023-02-16T10:17:46-05:00 Narrow the dont-decompose-newtype test Following #22924 this patch narrows the test that stops us decomposing newtypes. The key change is the use of noGivenNewtypeReprEqs in GHC.Tc.Solver.Canonical.canTyConApp. We went to and fro on the solution, as you can see in #22924. The result is carefully documented in Note [Decomoposing newtype equalities] On the way I had revert most of commit 3e827c3f74ef76d90d79ab6c4e71aa954a1a6b90 Author: Richard Eisenberg <rae at cs.brynmawr.edu> Date: Mon Dec 5 10:14:02 2022 -0500 Do newtype unwrapping in the canonicaliser and rewriter See Note [Unwrap newtypes first], which has the details. It turns out that (a) 3e827c3f makes GHC behave worse on some recursive newtypes (see one of the tests on this commit) (b) the finer-grained test (namely noGivenNewtypeReprEqs) renders 3e827c3f unnecessary - - - - - 5b038888 by Bodigrim at 2023-02-16T10:18:24-05:00 Documentation: add an example of SPEC usage - - - - - 681e0e8c by sheaf at 2023-02-16T14:09:56-05:00 No default finalizer exception handler Commit cfc8e2e2 introduced a mechanism for handling of exceptions that occur during Handle finalization, and 372cf730 set the default handler to print out the error to stderr. However, #21680 pointed out we might not want to set this by default, as it might pollute users' terminals with unwanted information. So, for the time being, the default handler discards the exception. Fixes #21680 - - - - - b3ac17ad by Matthew Pickering at 2023-02-16T14:10:31-05:00 unicode: Don't inline bitmap in generalCategory generalCategory contains a huge literal string but is marked INLINE, this will duplicate the string into any use site of generalCategory. In particular generalCategory is used in functions like isSpace and the literal gets inlined into this function which makes it massive. https://github.com/haskell/core-libraries-committee/issues/130 Fixes #22949 ------------------------- Metric Decrease: T4029 T18304 ------------------------- - - - - - 8988eeef by sheaf at 2023-02-16T20:32:27-05:00 Expand synonyms in RoughMap We were failing to expand type synonyms in the function GHC.Core.RoughMap.typeToRoughMatchLookupTc, even though the RoughMap infrastructure crucially relies on type synonym expansion to work. This patch adds the missing type-synonym expansion. Fixes #22985 - - - - - 3dd50e2f by Matthew Pickering at 2023-02-16T20:33:03-05:00 ghcup-metadata: Add test artifact Add the released testsuite tarball to the generated ghcup metadata. - - - - - c6a967d9 by Matthew Pickering at 2023-02-16T20:33:03-05:00 ghcup-metadata: Use Ubuntu and Rocky bindists Prefer to use the Ubuntu 20.04 and 18.04 binary distributions on Ubuntu and Linux Mint. Prefer to use the Rocky 8 binary distribution on unknown distributions. - - - - - be0b7209 by Matthew Pickering at 2023-02-17T09:37:16+00:00 Add INLINABLE pragmas to `generic*` functions in Data.OldList These functions are * recursive * overloaded So it's important to add an `INLINABLE` pragma to each so that they can be specialised at the use site when the specific numeric type is known. Adding these pragmas improves the LazyText replicate benchmark (see https://gitlab.haskell.org/ghc/ghc/-/issues/22886#note_481020) https://github.com/haskell/core-libraries-committee/issues/129 - - - - - a203ad85 by Sylvain Henry at 2023-02-17T15:59:16-05:00 Merge libiserv with ghci `libiserv` serves no purpose. As it depends on `ghci` and doesn't have more dependencies than the `ghci` package, its code could live in the `ghci` package too. This commit also moves most of the code from the `iserv` program into the `ghci` package as well so that it can be reused. This is especially useful for the implementation of TH for the JS backend (#22261, !9779). - - - - - 7080a93f by Simon Peyton Jones at 2023-02-20T12:06:32+01:00 Improve GHC.Tc.Gen.App.tcInstFun It wasn't behaving right when inst_final=False, and the function had no type variables f :: Foo => Int Rather a corner case, but we might as well do it right. Fixes #22908 Unexpectedly, three test cases (all using :type in GHCi) got slightly better output as a result: T17403, T14796, T12447 - - - - - 2592ab69 by Cheng Shao at 2023-02-20T10:35:30-05:00 compiler: fix cost centre profiling breakage in wasm NCG due to incorrect register mapping The wasm NCG used to map CCCS to a wasm global, based on the observation that CCCS is a transient register that's already handled by thread state load/store logic, so it doesn't need to be backed by the rCCCS field in the register table. Unfortunately, this is wrong, since even when Cmm execution hasn't yielded back to the scheduler, the Cmm code may call enterFunCCS, which does use rCCCS. This breaks cost centre profiling in a subtle way, resulting in inaccurate stack traces in some test cases. The fix is simple though: just remove the CCCS mapping. - - - - - 26243de1 by Alexis King at 2023-02-20T15:27:17-05:00 Handle top-level Addr# literals in the bytecode compiler Fixes #22376. - - - - - 0196cc2b by romes at 2023-02-20T15:27:52-05:00 fix: Explicitly flush stdout on plugin Because of #20791, the plugins tests often fail. This is a temporary fix to stop the tests from failing due to unflushed outputs on windows and the explicit flush should be removed when #20791 is fixed. - - - - - 4327d635 by Ryan Scott at 2023-02-20T20:44:34-05:00 Don't generate datacon wrappers for `type data` declarations Data constructor wrappers only make sense for _value_-level data constructors, but data constructors for `type data` declarations only exist at the _type_ level. This patch does the following: * The criteria in `GHC.Types.Id.Make.mkDataConRep` for whether a data constructor receives a wrapper now consider whether or not its parent data type was declared with `type data`, omitting a wrapper if this is the case. * Now that `type data` data constructors no longer receive wrappers, there is a spot of code in `refineDefaultAlt` that panics when it encounters a value headed by a `type data` type constructor. I've fixed this with a special case in `refineDefaultAlt` and expanded `Note [Refine DEFAULT case alternatives]` to explain why we do this. Fixes #22948. - - - - - 96dc58b9 by Ryan Scott at 2023-02-20T20:44:35-05:00 Treat type data declarations as empty when checking pattern-matching coverage The data constructors for a `type data` declaration don't exist at the value level, so we don't want GHC to warn users to match on them. Fixes #22964. - - - - - ff8e99f6 by Ryan Scott at 2023-02-20T20:44:35-05:00 Disallow `tagToEnum#` on `type data` types We don't want to allow users to conjure up values of a `type data` type using `tagToEnum#`, as these simply don't exist at the value level. - - - - - 8e765aff by Bodigrim at 2023-02-21T12:03:24-05:00 Bump submodule text to 2.0.2 - - - - - 172ff88f by Georgi Lyubenov at 2023-02-21T18:35:56-05:00 GHC proposal 496 - Nullary record wildcards This patch implements GHC proposal 496, which allows record wildcards to be used for nullary constructors, e.g. data A = MkA1 | MkA2 { fld1 :: Int } f :: A -> Int f (MkA1 {..}) = 0 f (MkA2 {..}) = fld1 To achieve this, we add arity information to the record field environment, so that we can accept a constructor which has no fields while continuing to reject non-record constructors with more than 1 field. See Note [Nullary constructors and empty record wildcards], as well as the more general overview in Note [Local constructor info in the renamer], both in the newly introduced GHC.Types.ConInfo module. Fixes #22161 - - - - - f70a0239 by sheaf at 2023-02-21T18:36:35-05:00 ghc-prim: levity-polymorphic array equality ops This patch changes the pointer-equality comparison operations in GHC.Prim.PtrEq to work with arrays of unlifted values, e.g. sameArray# :: forall {l} (a :: TYPE (BoxedRep l)). Array# a -> Array# a -> Int# Fixes #22976 - - - - - 9296660b by Andreas Klebinger at 2023-02-21T23:58:05-05:00 base: Correct @since annotation for FP<->Integral bit cast operations. Fixes #22708 - - - - - f11d9c27 by romes at 2023-02-21T23:58:42-05:00 fix: Update documentation links Closes #23008 Additionally batches some fixes to pointers to the Note [Wired-in units], and a typo in said note. - - - - - fb60339f by Bryan Richter at 2023-02-23T14:45:17+02:00 Propagate failure if unable to push notes - - - - - 8e170f86 by Alexis King at 2023-02-23T16:59:22-05:00 rts: Fix `prompt#` when profiling is enabled This commit also adds a new -Dk RTS option to the debug RTS to assist debugging continuation captures. Currently, the printed information is quite minimal, but more can be added in the future if it proves to be useful when debugging future issues. fixes #23001 - - - - - e9e7a00d by sheaf at 2023-02-23T17:00:01-05:00 Explicit migration timeline for loopy SC solving This patch updates the warning message introduced in commit 9fb4ca89bff9873e5f6a6849fa22a349c94deaae to specify an explicit migration timeline: GHC will no longer support this constraint solving mechanism starting from GHC 9.10. Fixes #22912 - - - - - 4eb9c234 by Sylvain Henry at 2023-02-24T17:27:45-05:00 JS: make some arithmetic primops faster (#22835) Don't use BigInt for wordAdd2, mulWord32, and timesInt32. Co-authored-by: Matthew Craven <5086-clyring at users.noreply.gitlab.haskell.org> - - - - - 92e76483 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump terminfo submodule to 0.4.1.6 - - - - - f229db14 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump unix submodule to 2.8.1.0 - - - - - 47bd48c1 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump deepseq submodule to 1.4.8.1 - - - - - d2012594 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump directory submodule to 1.3.8.1 - - - - - df6f70d1 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump process submodule to v1.6.17.0 - - - - - 4c869e48 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump hsc2hs submodule to 0.68.8 - - - - - 81d96642 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump array submodule to 0.5.4.0 - - - - - 6361f771 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump Cabal submodule to 3.9 pre-release - - - - - 4085fb6c by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump filepath submodule to 1.4.100.1 - - - - - 2bfad50f by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump haskeline submodule to 0.8.2.1 - - - - - fdc89a8d by Ben Gamari at 2023-02-24T21:29:32-05:00 gitlab-ci: Run nix-build with -v0 This significantly cuts down on the amount of noise in the job log. Addresses #22861. - - - - - 69fb0b13 by Aaron Allen at 2023-02-24T21:30:10-05:00 Fix ParallelListComp out of scope suggestion This patch makes it so vars from one block of a parallel list comprehension are not in scope in a subsequent block during type checking. This was causing GHC to emit a faulty suggestion when an out of scope variable shared the occ name of a var from a different block. Fixes #22940 - - - - - ece092d0 by Simon Peyton Jones at 2023-02-24T21:30:45-05:00 Fix shadowing bug in prepareAlts As #23012 showed, GHC.Core.Opt.Simplify.Utils.prepareAlts was using an OutType to construct an InAlt. When shadowing is in play, this is outright wrong. See Note [Shadowing in prepareAlts]. - - - - - 7825fef9 by Sylvain Henry at 2023-02-24T21:31:25-05:00 JS: Store CI perf results (fix #22923) - - - - - b56025f4 by Gergő Érdi at 2023-02-27T13:34:22+00:00 Don't specialise incoherent instance applications Using incoherent instances, there can be situations where two occurrences of the same overloaded function at the same type use two different instances (see #22448). For incoherently resolved instances, we must mark them with `nospec` to avoid the specialiser rewriting one to the other. This marking is done during the desugaring of the `WpEvApp` wrapper. Fixes #22448 Metric Increase: T15304 - - - - - d0c7bbed by Tom Ellis at 2023-02-27T20:04:07-05:00 Fix SCC grouping example - - - - - f84a8cd4 by Bryan Richter at 2023-02-28T05:58:37-05:00 Mark setnumcapabilities001 fragile - - - - - 29a04d6e by Bryan Richter at 2023-02-28T05:58:37-05:00 Allow nightly-x86_64-linux-deb10-validate+thread_sanitizer to fail See #22520 - - - - - 9fa54572 by Cheng Shao at 2023-02-28T05:59:15-05:00 ghc-prim: fix hs_cmpxchg64 function prototype hs_cmpxchg64 must return a StgWord64, otherwise incorrect runtime results of 64-bit MO_Cmpxchg will appear in 32-bit unregisterised builds, which go unnoticed at compile-time due to C implicit casting in .hc files. - - - - - 0c200ab7 by Simon Peyton Jones at 2023-02-28T11:10:31-05:00 Account for local rules in specImports As #23024 showed, in GHC.Core.Opt.Specialise.specImports, we were generating specialisations (a locally-define function) for imported functions; and then generating specialisations for those locally-defined functions. The RULE for the latter should be attached to the local Id, not put in the rules-for-imported-ids set. Fix is easy; similar to what happens in GHC.HsToCore.addExportFlagsAndRules - - - - - 8b77f9bf by Sylvain Henry at 2023-02-28T11:11:21-05:00 JS: fix for overlap with copyMutableByteArray# (#23033) The code wasn't taking into account some kind of overlap. cgrun070 has been extended to test the missing case. - - - - - 239202a2 by Sylvain Henry at 2023-02-28T11:12:03-05:00 Testsuite: replace some js_skip with req_cmm req_cmm is more informative than js_skip - - - - - 7192ef91 by Simon Peyton Jones at 2023-02-28T18:54:59-05:00 Take more care with unlifted bindings in the specialiser As #22998 showed, we were floating an unlifted binding to top level, which breaks a Core invariant. The fix is easy, albeit a little bit conservative. See Note [Care with unlifted bindings] in GHC.Core.Opt.Specialise - - - - - bb500e2a by Simon Peyton Jones at 2023-02-28T18:55:35-05:00 Account for TYPE vs CONSTRAINT in mkSelCo As #23018 showed, in mkRuntimeRepCo we need to account for coercions between TYPE and COERCION. See Note [mkRuntimeRepCo] in GHC.Core.Coercion. - - - - - 79ffa170 by Ben Gamari at 2023-03-01T04:17:20-05:00 hadrian: Add dependency from lib/settings to mk/config.mk In 81975ef375de07a0ea5a69596b2077d7f5959182 we attempted to fix #20253 by adding logic to the bindist Makefile to regenerate the `settings` file from information gleaned by the bindist `configure` script. However, this fix had no effect as `lib/settings` is shipped in the binary distribution (to allow in-place use of the binary distribution). As `lib/settings` already existed and its rule declared no dependencies, `make` would fail to use the added rule to regenerate it. Fix this by explicitly declaring a dependency from `lib/settings` on `mk/config.mk`. Fixes #22982. - - - - - a2a1a1c0 by Sebastian Graf at 2023-03-01T04:17:56-05:00 Revert the main payload of "Make `drop` and `dropWhile` fuse (#18964)" This reverts the bits affecting fusion of `drop` and `dropWhile` of commit 0f7588b5df1fc7a58d8202761bf1501447e48914 and keeps just the small refactoring unifying `flipSeqTake` and `flipSeqScanl'` into `flipSeq`. It also adds a new test for #23021 (which was the reason for reverting) as well as adds a clarifying comment to T18964. Fixes #23021, unfixes #18964. Metric Increase: T18964 Metric Decrease: T18964 - - - - - cf118e2f by Simon Peyton Jones at 2023-03-01T04:18:33-05:00 Refine the test for naughty record selectors The test for naughtiness in record selectors is surprisingly subtle. See the revised Note [Naughty record selectors] in GHC.Tc.TyCl.Utils. Fixes #23038. - - - - - 86f240ca by romes at 2023-03-01T04:19:10-05:00 fix: Consider strictness annotation in rep_bind Fixes #23036 - - - - - 1ed573a5 by Richard Eisenberg at 2023-03-02T22:42:06-05:00 Don't suppress *all* Wanteds Code in GHC.Tc.Errors.reportWanteds suppresses a Wanted if its rewriters have unfilled coercion holes; see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. But if we thereby suppress *all* errors that's really confusing, and as #22707 shows, GHC goes on without even realising that the program is broken. Disaster. This MR arranges to un-suppress them all if they all get suppressed. Close #22707 - - - - - 8919f341 by Luite Stegeman at 2023-03-02T22:42:45-05:00 Check for platform support for JavaScript foreign imports GHC was accepting `foreign import javascript` declarations on non-JavaScript platforms. This adds a check so that these are only supported on an platform that supports the JavaScript calling convention. Fixes #22774 - - - - - db83f8bb by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Statically assert alignment of Capability In #22965 we noticed that changes in the size of `Capability` can result in unsound behavior due to the `align` pragma claiming an alignment which we don't in practice observe. Avoid this by statically asserting that the size is a multiple of the alignment. - - - - - 5f7a4a6d by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Introduce stgMallocAlignedBytes - - - - - 8a6f745d by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Correctly align Capability allocations Previously we failed to tell the C allocator that `Capability`s needed to be aligned, resulting in #22965. Fixes #22965. Fixes #22975. - - - - - 5464c73f by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Drop no-alignment special case for Windows For reasons that aren't clear, we were previously not giving Capability the same favorable alignment on Windows that we provided on other platforms. Fix this. - - - - - a86aae8b by Matthew Pickering at 2023-03-02T22:43:59-05:00 constant folding: Correct type of decodeDouble_Int64 rule The first argument is Int64# unconditionally, so we better produce something of that type. This fixes a core lint error found in the ad package. Fixes #23019 - - - - - 68dd64ff by Zubin Duggal at 2023-03-02T22:44:35-05:00 ncg/aarch64: Handle MULTILINE_COMMENT identically as COMMENTs Commit 7566fd9de38c67360c090f828923d41587af519c with the fix for #22798 was incomplete as it failed to handle MULTILINE_COMMENT pseudo-instructions, and didn't completly fix the compiler panics when compiling with `-fregs-graph`. Fixes #23002 - - - - - 2f97c861 by Simon Peyton Jones at 2023-03-02T22:45:11-05:00 Get the right in-scope set in etaBodyForJoinPoint Fixes #23026 - - - - - 45af8482 by David Feuer at 2023-03-03T11:40:47-05:00 Export getSolo from Data.Tuple Proposed in [CLC proposal #113](https://github.com/haskell/core-libraries-committee/issues/113) and [approved by the CLC](https://github.com/haskell/core-libraries-committee/issues/113#issuecomment-1452452191) - - - - - 0c694895 by David Feuer at 2023-03-03T11:40:47-05:00 Document getSolo - - - - - bd0536af by Simon Peyton Jones at 2023-03-03T11:41:23-05:00 More fixes for `type data` declarations This MR fixes #23022 and #23023. Specifically * Beef up Note [Type data declarations] in GHC.Rename.Module, to make invariant (I1) explicit, and to name the several wrinkles. And add references to these specific wrinkles. * Add a Lint check for invariant (I1) above. See GHC.Core.Lint.checkTypeDataConOcc * Disable the `caseRules` for dataToTag# for `type data` values. See Wrinkle (W2c) in the Note above. Fixes #23023. * Refine the assertion in dataConRepArgTys, so that it does not complain about the absence of a wrapper for a `type data` constructor Fixes #23022. Acked-by: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - 858f34d5 by Oleg Grenrus at 2023-03-04T01:13:55+02:00 Add decideSymbol, decideChar, decideNat, decTypeRep, decT and hdecT These all type-level equality decision procedures. Implementes a CLC proposal https://github.com/haskell/core-libraries-committee/issues/98 - - - - - bf43ba92 by Simon Peyton Jones at 2023-03-04T01:18:23-05:00 Add test for T22793 - - - - - c6e1f3cd by Chris Wendt at 2023-03-04T03:35:18-07:00 Fix typo in docs referring to threadLabel - - - - - 232cfc24 by Simon Peyton Jones at 2023-03-05T19:57:30-05:00 Add regression test for #22328 - - - - - 5ed77deb by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Enable response files for linker if supported - - - - - 1e0f6c89 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Synchronize `configure.ac` and `distrib/configure.ac.in` - - - - - 70560952 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Fix `hadrian/bindist/config.mk.in` … as suggested by @bgamari - - - - - b042b125 by sheaf at 2023-03-06T17:06:50-05:00 Apply 1 suggestion(s) to 1 file(s) - - - - - 674b6b81 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Try to create somewhat portable `ld` command I cannot figure out a good way to generate an `ld` command that works on both Linux and macOS. Normally you'd use something like `AC_LINK_IFELSE` for this purpose (I think), but that won't let us test response file support. - - - - - 83b0177e by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Quote variables … as suggested by @bgamari - - - - - 845f404d by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Fix configure failure on alpine linux - - - - - c56a3ae6 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Small fixes to configure script - - - - - cad5c576 by Andrei Borzenkov at 2023-03-06T17:07:33-05:00 Convert diagnostics in GHC.Rename.Module to proper TcRnMessage (#20115) I've turned almost all occurrences of TcRnUnknownMessage in GHC.Rename.Module module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnIllegalInstanceHeadDecl TcRnUnexpectedStandaloneDerivingDecl TcRnUnusedVariableInRuleDecl TcRnUnexpectedStandaloneKindSig TcRnIllegalRuleLhs TcRnBadAssocRhs TcRnDuplicateRoleAnnot TcRnDuplicateKindSig TcRnIllegalDerivStrategy TcRnIllegalMultipleDerivClauses TcRnNoDerivStratSpecified TcRnStupidThetaInGadt TcRnBadImplicitSplice TcRnShadowedTyVarNameInFamResult TcRnIncorrectTyVarOnLhsOfInjCond TcRnUnknownTyVarsOnRhsOfInjCond Was introduced one helper type: RuleLhsErrReason - - - - - c6432eac by Apoorv Ingle at 2023-03-06T23:26:12+00:00 Constraint simplification loop now depends on `ExpansionFuel` instead of a boolean flag for `CDictCan.cc_pend_sc`. Pending givens get a fuel of 3 while Wanted and quantified constraints get a fuel of 1. This helps pending given constraints to keep up with pending wanted constraints in case of `UndecidableSuperClasses` and superclass expansions while simplifying the infered type. Adds 3 dynamic flags for controlling the fuels for each type of constraints `-fgivens-expansion-fuel` for givens `-fwanteds-expansion-fuel` for wanteds and `-fqcs-expansion-fuel` for quantified constraints Fixes #21909 Added Tests T21909, T21909b Added Note [Expanding Recursive Superclasses and ExpansionFuel] - - - - - a5afc8ab by Bodigrim at 2023-03-06T22:51:01-05:00 Documentation: describe laziness of several function from Data.List - - - - - fa559c28 by Ollie Charles at 2023-03-07T20:56:21+00:00 Add `Data.Functor.unzip` This function is currently present in `Data.List.NonEmpty`, but `Data.Functor` is a better home for it. This change was discussed and approved by the CLC at https://github.com/haskell/core-libraries-committee/issues/88. - - - - - 2aa07708 by MorrowM at 2023-03-07T21:22:22-05:00 Fix documentation for traceWith and friends - - - - - f3ff7cb1 by David Binder at 2023-03-08T01:24:17-05:00 Remove utils/hpc subdirectory and its contents - - - - - cf98e286 by David Binder at 2023-03-08T01:24:17-05:00 Add git submodule for utils/hpc - - - - - 605fbbb2 by David Binder at 2023-03-08T01:24:18-05:00 Update commit for utils/hpc git submodule - - - - - 606793d4 by David Binder at 2023-03-08T01:24:18-05:00 Update commit for utils/hpc git submodule - - - - - 4158722a by Sylvain Henry at 2023-03-08T01:24:58-05:00 linker: fix linking with aligned sections (#23066) Take section alignment into account instead of assuming 16 bytes (which is wrong when the section requires 32 bytes, cf #23066). - - - - - 1e0d8fdb by Greg Steuck at 2023-03-08T08:59:05-05:00 Change hostSupportsRPaths to report False on OpenBSD OpenBSD does support -rpath but ghc build process relies on some related features that don't work there. See ghc/ghc#23011 - - - - - bed3a292 by Alexis King at 2023-03-08T08:59:53-05:00 bytecode: Fix bitmaps for BCOs used to tag tuples and prim call args fixes #23068 - - - - - 321d46d9 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Drop redundant prototype - - - - - abb6070f by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix style - - - - - be278901 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Deduplicate assertion - - - - - b9034639 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Fix type issues in Sparks.h Adds explicit casts to satisfy a C++ compiler. - - - - - da7b2b94 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Use release ordering when storing thread labels Since this makes the ByteArray# visible from other cores. - - - - - 5b7f6576 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/BlockAlloc: Allow disabling of internal assertions These can be quite expensive and it is sometimes useful to compile a DEBUG RTS without them. - - - - - 6283144f by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/Sanity: Mark pinned_object_blocks - - - - - 9b528404 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/Sanity: Look at nonmoving saved_filled lists - - - - - 0edc5438 by Ben Gamari at 2023-03-08T15:02:30-05:00 Evac: Squash data race in eval_selector_chain - - - - - 7eab831a by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Clarify implementation This makes the intent of this implementation a bit clearer. - - - - - 532262b9 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Clarify comment - - - - - bd9cd84b by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Add missing no-op in busy-wait loop - - - - - c4e6bfc8 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't push empty arrays to update remembered set Previously the write barrier of resizeSmallArray# incorrectly handled resizing of zero-sized arrays, pushing an invalid pointer to the update remembered set. Fixes #22931. - - - - - 92227b60 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix handling of weak pointers This fixes an interaction between aging and weak pointer handling which prevented the finalization of some weak pointers. In particular, weak pointers could have their keys incorrectly marked by the preparatory collector, preventing their finalization by the subsequent concurrent collection. While in the area, we also significantly improve the assertions regarding weak pointers. Fixes #22327. - - - - - ba7e7972 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Sanity check nonmoving large objects and compacts - - - - - 71b038a1 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Sanity check mutable list Assert that entries in the nonmoving generation's generational remembered set (a.k.a. mutable list) live in nonmoving generation. - - - - - 99d144d5 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't show occupancy if we didn't collect live words - - - - - 81d6cc55 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix tracking of FILLED_SWEEPING segments Previously we only updated the state of the segment at the head of each allocator's filled list. - - - - - 58e53bc4 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Assert state of swept segments - - - - - 2db92e01 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Handle new closures in nonmovingIsNowAlive We must conservatively assume that new closures are reachable since we are not guaranteed to mark such blocks. - - - - - e4c3249f by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't clobber update rem sets of old capabilities Previously `storageAddCapabilities` (called by `setNumCapabilities`) would clobber the update remembered sets of existing capabilities when increasing the capability count. Fix this by only initializing the update remembered sets of the newly-created capabilities. Fixes #22927. - - - - - 1b069671 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Add missing write barriers in selector optimisation This fixes the selector optimisation, adding a few write barriers which are necessary for soundness. See the inline comments for details. Fixes #22930. - - - - - d4032690 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Post-sweep sanity checking - - - - - 0baa8752 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Avoid n_caps race - - - - - 5d3232ba by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Don't push if nonmoving collector isn't enabled - - - - - 0a7eb0aa by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Be more paranoid in segment tracking Previously we left various segment link pointers dangling. None of this wrong per se, but it did make it harder than necessary to debug. - - - - - 7c817c0a by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Sync-phase mark budgeting Here we significantly improve the bound on sync phase pause times by imposing a limit on the amount of work that we can perform during the sync. If we find that we have exceeded our marking budget then we allow the mutators to resume, return to concurrent marking, and try synchronizing again later. Fixes #22929. - - - - - ce22a3e2 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Allow pinned gen0 objects to be WEAK keys - - - - - 78746906 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Reenable assertion - - - - - b500867a by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Move current segment array into Capability The current segments are conceptually owned by the mutator, not the collector. Consequently, it was quite tricky to prove that the mutator would not race with the collect due to this shared state. It turns out that such races are possible: when resizing the current segment array we may concurrently try to take a heap census. This will attempt to walk the current segment array, causing a data race. Fix this by moving the current segment array into `Capability`, where it belongs. Fixes #22926. - - - - - 56e669c1 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Fix Note references Some references to Note [Deadlock detection under the non-moving collector] were missing an article. - - - - - 4a7650d7 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts/Sanity: Fix block count assertion with non-moving collector The nonmoving collector does not use `oldest_gen->blocks` to track its block list. However, it nevertheless updates `oldest_gen->n_blocks` to ensure that its size is accounted for by the storage manager. Consequently, we must not attempt to assert consistency between the two. - - - - - 96a5aaed by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Don't call prepareUnloadCheck When the nonmoving GC is in use we do not call `checkUnload` (since we don't unload code) and therefore should not call `prepareUnloadCheck`, lest we run into assertions. - - - - - 6c6674ca by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Encapsulate block allocator spinlock This makes it a bit easier to add instrumentation on this spinlock while debugging. - - - - - e84f7167 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Skip some tests when sanity checking is enabled - - - - - 3ae0f368 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Fix unregisterised build - - - - - 4eb9d06b by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Ensure that sanity checker accounts for saved_filled segments - - - - - f0cf384d by Ben Gamari at 2023-03-08T15:02:31-05:00 hadrian: Add +boot_nonmoving_gc flavour transformer For using GHC bootstrapping to validate the non-moving GC. - - - - - 581e58ac by Ben Gamari at 2023-03-08T15:02:31-05:00 gitlab-ci: Add job bootstrapping with nonmoving GC - - - - - 487a8b58 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Move allocator into new source file - - - - - 8f374139 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Split out nonmovingAllocateGC - - - - - 662b6166 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Only run T22795* in the normal way It doesn't make sense to run these in multiple ways as they merely test whether `-threaded`/`-single-threaded` flags. - - - - - 0af21dfa by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Rename clear_segment(_free_blocks)? To reflect the fact that these are to do with the nonmoving collector, now since they are exposed no longer static. - - - - - 7bcb192b by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Fix incorrect STATIC_INLINE This should be INLINE_HEADER lest we get unused declaration warnings. - - - - - f1fd3ffb by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Mark ffi023 as broken due to #23089 - - - - - a57f12b3 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Skip T7160 in the nonmoving way Finalization order is different under the nonmoving collector. - - - - - f6f12a36 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Capture GC configuration in a struct The number of distinct arguments passed to GarbageCollect was getting a bit out of hand. - - - - - ba73a807 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Non-concurrent collection - - - - - 7c813d06 by Alexis King at 2023-03-08T15:03:10-05:00 hadrian: Fix flavour compiler stage options off-by-one error !9193 pointed out that ghcDebugAssertions was supposed to be a predicate on the stage of the built compiler, but in practice it was a predicate on the stage of the compiler used to build. Unfortunately, while it fixed that issue for ghcDebugAssertions, it documented every other similar option as behaving the same way when in fact they all used the old behavior. The new behavior of ghcDebugAssertions seems more intuitive, so this commit changes the interpretation of every other option to match. It also improves the enableProfiledGhc and debugGhc flavour transformers by making them more selective about which stages in which they build additional library/RTS ways. - - - - - f97c7f6d by Luite Stegeman at 2023-03-09T09:52:09-05:00 Delete created temporary subdirectories at end of session. This patch adds temporary subdirectories to the list of paths do clean up at the end of the GHC session. This fixes warnings about non-empty temporary directories. Fixes #22952 - - - - - 9ea719f2 by Apoorv Ingle at 2023-03-09T09:52:45-05:00 Fixes #19627. Previously the solver failed with an unhelpful "solver reached too may iterations" error. With the fix for #21909 in place we no longer have the possibility of generating such an error if we have `-fconstraint-solver-iteration` > `-fgivens-fuel > `-fwanteds-fuel`. This is true by default, and the said fix also gives programmers a knob to control how hard the solver should try before giving up. This commit adds: * Reference to ticket #19627 in the Note [Expanding Recursive Superclasses and ExpansionFuel] * Test `typecheck/should_fail/T19627.hs` for regression purposes - - - - - ec2d93eb by Sebastian Graf at 2023-03-10T10:18:54-05:00 DmdAnal: Fix a panic on OPAQUE and trivial/PAP RHS (#22997) We should not panic in `add_demands` (now `set_lam_dmds`), because that code path is legimitely taken for OPAQUE PAP bindings, as in T22997. Fixes #22997. - - - - - 5b4628ae by Sylvain Henry at 2023-03-10T10:19:34-05:00 JS: remove dead code for old integer-gmp - - - - - bab23279 by Josh Meredith at 2023-03-10T23:24:49-05:00 JS: Fix implementation of MK_JSVAL - - - - - ec263a59 by Sebastian Graf at 2023-03-10T23:25:25-05:00 Simplify: Move `wantEtaExpansion` before expensive `do_eta_expand` check There is no need to run arity analysis and what not if we are not in a Simplifier phase that eta-expands or if we don't want to eta-expand the expression in the first place. Purely a refactoring with the goal of improving compiler perf. - - - - - 047e9d4f by Josh Meredith at 2023-03-13T03:56:03+00:00 JS: fix implementation of forceBool to use JS backend syntax - - - - - 559a4804 by Sebastian Graf at 2023-03-13T07:31:23-04:00 Simplifier: `countValArgs` should not count Type args (#23102) I observed miscompilations while working on !10088 caused by this. Fixes #23102. Metric Decrease: T10421 - - - - - 536d1f90 by Matthew Pickering at 2023-03-13T14:04:49+00:00 Bump Win32 to 2.13.4.0 Updates Win32 submodule - - - - - ee17001e by Ben Gamari at 2023-03-13T21:18:24-04:00 ghc-bignum: Drop redundant include-dirs field - - - - - c9c26cd6 by Teo Camarasu at 2023-03-16T12:17:50-04:00 Fix BCO creation setting caps when -j > -N * Remove calls to 'setNumCapabilities' in 'createBCOs' These calls exist to ensure that 'createBCOs' can benefit from parallelism. But this is not the right place to call `setNumCapabilities`. Furthermore the logic differs from that in the driver causing the capability count to be raised and lowered at each TH call if -j > -N. * Remove 'BCOOpts' No longer needed as it was only used to thread the job count down to `createBCOs` Resolves #23049 - - - - - 5ddbf5ed by Teo Camarasu at 2023-03-16T12:17:50-04:00 Add changelog entry for #23049 - - - - - 6e3ce9a4 by Ben Gamari at 2023-03-16T12:18:26-04:00 configure: Fix FIND_CXX_STD_LIB test on Darwin Annoyingly, Darwin's <cstddef> includes <version> and APFS is case-insensitive. Consequently, it will end up #including the `VERSION` file generated by the `configure` script on the second and subsequent runs of the `configure` script. See #23116. - - - - - 19d6d039 by sheaf at 2023-03-16T21:31:22+01:00 ghci: only keep the GlobalRdrEnv in ModInfo The datatype GHC.UI.Info.ModInfo used to store a ModuleInfo, which includes a TypeEnv. This can easily cause space leaks as we have no way of forcing everything in a type environment. In GHC, we only use the GlobalRdrEnv, which we can force completely. So we only store that instead of a fully-fledged ModuleInfo. - - - - - 73d07c6e by Torsten Schmits at 2023-03-17T14:36:49-04:00 Add structured error messages for GHC.Tc.Utils.Backpack Tracking ticket: #20119 MR: !10127 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. One occurrence, when handing a nested error from the interface loading machinery, was omitted. It will be handled by a subsequent changeset that addresses interface errors. - - - - - a13affce by Andrei Borzenkov at 2023-03-21T11:17:17-04:00 Rename () into Unit, (,,...,,) into Tuple<n> (#21294) This patch implements a part of GHC Proposal #475. The key change is in GHC.Tuple.Prim: - data () = () - data (a,b) = (a,b) - data (a,b,c) = (a,b,c) ... + data Unit = () + data Tuple2 a b = (a,b) + data Tuple3 a b c = (a,b,c) ... And the rest of the patch makes sure that Unit and Tuple<n> are pretty-printed as () and (,,...,,) in various contexts. Updates the haddock submodule. Co-authored-by: Vladislav Zavialov <vlad.z.4096 at gmail.com> - - - - - 23642bf6 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: fix some wrongs in the eventlog format documentation - - - - - 90159773 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: explain the BLOCK_MARKER event - - - - - ab1c25e8 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add BlockedOnMVarRead thread status in eventlog encodings - - - - - 898afaef by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add TASK_DELETE event in eventlog encodings - - - - - bb05b4cc by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add WALL_CLOCK_TIME event in eventlog encodings - - - - - eeea0343 by Torsten Schmits at 2023-03-21T11:18:34-04:00 Add structured error messages for GHC.Tc.Utils.Env Tracking ticket: #20119 MR: !10129 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - be1d4be8 by Bodigrim at 2023-03-21T11:19:13-04:00 Document pdep / pext primops - - - - - e8b4aac4 by Alex Mason at 2023-03-21T18:11:04-04:00 Allow LLVM backend to use HDoc for faster file generation. Also remove the MetaStmt constructor from LlvmStatement and places the annotations into the Store statement. Includes “Implement a workaround for -no-asm-shortcutting bug“ (https://gitlab.haskell.org/ghc/ghc/-/commit/2fda9e0df886cc551e2cd6b9c2a384192bdc3045) - - - - - ea24360d by Luite Stegeman at 2023-03-21T18:11:44-04:00 Compute LambdaFormInfo when using JavaScript backend. CmmCgInfos is needed to write interface files, but the JavaScript backend does not generate it, causing "Name without LFInfo" warnings. This patch adds a conservative but always correct CmmCgInfos when the JavaScript backend is used. Fixes #23053 - - - - - 926ad6de by Simon Peyton Jones at 2023-03-22T01:03:08-04:00 Be more careful about quantification This MR is driven by #23051. It does several things: * It is guided by the generalisation plan described in #20686. But it is still far from a complete implementation of that plan. * Add Note [Inferred type with escaping kind] to GHC.Tc.Gen.Bind. This explains that we don't (yet, pending #20686) directly prevent generalising over escaping kinds. * In `GHC.Tc.Utils.TcMType.defaultTyVar` we default RuntimeRep and Multiplicity variables, beause we don't want to quantify over them. We want to do the same for a Concrete tyvar, but there is nothing sensible to default it to (unless it has kind RuntimeRep, in which case it'll be caught by an earlier case). So we promote instead. * Pure refactoring in GHC.Tc.Solver: * Rename decideMonoTyVars to decidePromotedTyVars, since that's what it does. * Move the actual promotion of the tyvars-to-promote from `defaultTyVarsAndSimplify` to `decidePromotedTyVars`. This is a no-op; just tidies up the code. E.g then we don't need to return the promoted tyvars from `decidePromotedTyVars`. * A little refactoring in `defaultTyVarsAndSimplify`, but no change in behaviour. * When making a TauTv unification variable into a ConcreteTv (in GHC.Tc.Utils.Concrete.makeTypeConcrete), preserve the occ-name of the type variable. This just improves error messages. * Kill off dead code: GHC.Tc.Utils.TcMType.newConcreteHole - - - - - 0ab0cc11 by Sylvain Henry at 2023-03-22T01:03:48-04:00 Testsuite: use appropriate predicate for ManyUbxSums test (#22576) - - - - - 048c881e by romes at 2023-03-22T01:04:24-04:00 fix: Incorrect @since annotations in GHC.TypeError Fixes #23128 - - - - - a1528b68 by Sylvain Henry at 2023-03-22T01:05:04-04:00 Testsuite: use req_interp predicate for T16318 (#22370) - - - - - ad765b6f by Sylvain Henry at 2023-03-22T01:05:04-04:00 Testsuite: use req_interp predicate for T20214 - - - - - e0b8eaf3 by Simon Peyton Jones at 2023-03-22T09:50:13+00:00 Refactor the constraint solver pipeline The big change is to put the entire type-equality solver into GHC.Tc.Solver.Equality, rather than scattering it over Canonical and Interact. Other changes * EqCt becomes its own data type, a bit like QCInst. This is great because EqualCtList is then just [EqCt] * New module GHC.Tc.Solver.Dict has come of the class-contraint solver. In due course it will be all. One step at a time. This MR is intended to have zero change in behaviour: it is a pure refactor. It opens the way to subsequent tidying up, we believe. - - - - - cedf9a3b by Torsten Schmits at 2023-03-22T15:31:18-04:00 Add structured error messages for GHC.Tc.Utils.TcMType Tracking ticket: #20119 MR: !10138 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 30d45e97 by Sylvain Henry at 2023-03-22T15:32:01-04:00 Testsuite: use js_skip for T2615 (#22374) - - - - - 8c98deba by Armando Ramirez at 2023-03-23T09:19:32-04:00 Optimized Foldable methods for Data.Functor.Compose Explicitly define length, elem, etc. in Foldable instance for Data.Functor.Compose Implementation of https://github.com/haskell/core-libraries-committee/issues/57 - - - - - bc066108 by Armando Ramirez at 2023-03-23T09:19:32-04:00 Additional optimized versions - - - - - 80fce576 by Bodigrim at 2023-03-23T09:19:32-04:00 Simplify minimum/maximum in instance Foldable (Compose f g) - - - - - 8cb88a5a by Bodigrim at 2023-03-23T09:19:32-04:00 Update changelog to mention changes to instance Foldable (Compose f g) - - - - - e1c8c41d by Torsten Schmits at 2023-03-23T09:20:13-04:00 Add structured error messages for GHC.Tc.TyCl.PatSyn Tracking ticket: #20117 MR: !10158 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - f932c589 by Adam Gundry at 2023-03-24T02:36:09-04:00 Allow WARNING pragmas to be controlled with custom categories Closes #17209. This implements GHC Proposal 541, allowing a WARNING pragma to be annotated with a category like so: {-# WARNING in "x-partial" head "This function is undefined on empty lists." #-} The user can then enable, disable and set the severity of such warnings using command-line flags `-Wx-partial`, `-Werror=x-partial` and so on. There is a new warning group `-Wextended-warnings` containing all these warnings. Warnings without a category are treated as if the category was `deprecations`, and are (still) controlled by the flags `-Wdeprecations` and `-Wwarnings-deprecations`. Updates Haddock submodule. - - - - - 0426515b by Adam Gundry at 2023-03-24T02:36:09-04:00 Move mention of warning groups change to 9.8.1 release notes - - - - - b8d783d2 by Ben Gamari at 2023-03-24T02:36:45-04:00 nativeGen/AArch64: Fix bitmask immediate predicate Previously the predicate for determining whether a logical instruction operand could be encoded as a bitmask immediate was far too conservative. This meant that, e.g., pointer untagged required five instructions whereas it should only require one. Fixes #23030. - - - - - 46120bb6 by Joachim Breitner at 2023-03-24T13:09:43-04:00 User's guide: Improve docs for -Wall previously it would list the warnings _not_ enabled by -Wall. That’s unnecessary round-about and was out of date. So let's just name the relevant warnings (based on `compiler/GHC/Driver/Flags.hs`). - - - - - 509d1f11 by Ben Gamari at 2023-03-24T13:10:20-04:00 codeGen/tsan: Disable instrumentation of unaligned stores There is some disagreement regarding the prototype of `__tsan_unaligned_write` (specifically whether it takes just the written address, or the address and the value as an argument). Moreover, I have observed crashes which appear to be due to it. Disable instrumentation of unaligned stores as a temporary mitigation. Fixes #23096. - - - - - 6a73655f by Li-yao Xia at 2023-03-25T00:02:44-04:00 base: Document GHC versions associated with past base versions in the changelog - - - - - 43bd7694 by Teo Camarasu at 2023-03-25T00:03:24-04:00 Add regression test for #17574 This test currently fails in the nonmoving way - - - - - f2d56bf7 by Teo Camarasu at 2023-03-25T00:03:24-04:00 fix: account for large and compact object stats with nonmoving gc Make sure that we keep track of the size of large and compact objects that have been moved onto the nonmoving heap. We keep track of their size and add it to the amount of live bytes in nonmoving segments to get the total size of the live nonmoving heap. Resolves #17574 - - - - - 7131b705 by David Feuer at 2023-03-25T00:04:04-04:00 Modify ThreadId documentation and comments For a long time, `GHC.Conc.Sync` has said ```haskell -- ToDo: data ThreadId = ThreadId (Weak ThreadId#) -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. ``` We are now actually capable of using `Weak# ThreadId#`, but the world has moved on. To support the `Show` and `Ord` instances, we'd need to store the thread ID number in the `ThreadId`. And it seems very difficult to continue to support `threadStatus` in that regime, since it needs to be able to explain how threads died. In addition, garbage collection of weak references can be quite expensive, and it would be hard to evaluate the cost over he whole ecosystem. As discussed in [this CLC issue](https://github.com/haskell/core-libraries-committee/issues/125), it doesn't seem very likely that we'll actually switch to weak references here. - - - - - c421bbbb by Ben Gamari at 2023-03-25T00:04:41-04:00 rts: Fix barriers of IND and IND_STATIC Previously IND and IND_STATIC lacked the acquire barriers enjoyed by BLACKHOLE. As noted in the (now updated) Note [Heap memory barriers], this barrier is critical to ensure that the indirectee is visible to the entering core. Fixes #22872. - - - - - 62fa7faa by Bodigrim at 2023-03-25T00:05:22-04:00 Improve documentation of atomicModifyMutVar2# - - - - - b2d14d0b by Cheng Shao at 2023-03-25T03:46:43-04:00 rts: use performBlockingMajorGC in hs_perform_gc and fix ffi023 This patch does a few things: - Add the missing RtsSymbols.c entry of performBlockingMajorGC - Make hs_perform_gc call performBlockingMajorGC, which restores previous behavior - Use hs_perform_gc in ffi023 - Remove rts_clearMemory() call in ffi023, it now works again in some test ways previously marked as broken. Fixes #23089 - - - - - d9ae24ad by Cheng Shao at 2023-03-25T03:46:44-04:00 testsuite: add the rts_clearMemory test case This patch adds a standalone test case for rts_clearMemory that mimics how it's typically used by wasm backend users and ensures this RTS API isn't broken by future RTS refactorings. Fixes #23901. - - - - - 80729d96 by Bodigrim at 2023-03-25T03:47:22-04:00 Improve documentation for resizing of byte arrays - - - - - c6ec4cd1 by Ben Gamari at 2023-03-25T20:23:47-04:00 rts: Don't rely on EXTERN_INLINE for slop-zeroing logic Previously we relied on calling EXTERN_INLINE functions defined in ClosureMacros.h from Cmm to zero slop. However, as far as I can tell, this is no longer safe to do in C99 as EXTERN_INLINE definitions may be emitted in each compilation unit. Fix this by explicitly declaring a new set of non-inline functions in ZeroSlop.c which can be called from Cmm and marking the ClosureMacros.h definitions as INLINE_HEADER. In the future we should try to eliminate EXTERN_INLINE. - - - - - c32abd4b by Ben Gamari at 2023-03-25T20:23:48-04:00 rts: Fix capability-count check in zeroSlop Previously `zeroSlop` examined `RtsFlags` to determine whether the program was single-threaded. This is wrong; a program may be started with `+RTS -N1` yet the process may later increase the capability count with `setNumCapabilities`. This lead to quite subtle and rare crashes. Fixes #23088. - - - - - 656d4cb3 by Ryan Scott at 2023-03-25T20:24:23-04:00 Add Eq/Ord instances for SSymbol, SChar, and SNat This implements [CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148). - - - - - 4f93de88 by David Feuer at 2023-03-26T15:33:02-04:00 Update and expand atomic modification Haddocks * The documentation for `atomicModifyIORef` and `atomicModifyIORef'` were incomplete, and the documentation for `atomicModifyIORef` was out of date. Update and expand. * Remove a useless lazy pattern match in the definition of `atomicModifyIORef`. The pair it claims to match lazily was already forced by `atomicModifyIORef2`. - - - - - e1fb56b2 by David Feuer at 2023-03-26T15:33:41-04:00 Document the constructor name for lists Derived `Data` instances use raw infix constructor names when applicable. The `Data.Data [a]` instance, if derived, would have a constructor name of `":"`. However, it actually uses constructor name `"(:)"`. Document this peculiarity. See https://github.com/haskell/core-libraries-committee/issues/147 - - - - - c1f755c4 by Simon Peyton Jones at 2023-03-27T22:09:41+01:00 Make exprIsConApp_maybe a bit cleverer Addresses #23159. See Note Note [Exploit occ-info in exprIsConApp_maybe] in GHC.Core.SimpleOpt. Compile times go down very slightly, but always go down, never up. Good! Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -1.8% T15703(normal) -1.2% GOOD geo. mean -0.1% minimum -1.8% maximum +0.0% Metric Decrease: CoOpt_Singletons T15703 - - - - - 76bb4c58 by Ryan Scott at 2023-03-28T08:12:08-04:00 Add COMPLETE pragmas to TypeRep, SSymbol, SChar, and SNat This implements [CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149). - - - - - 3f374399 by sheaf at 2023-03-29T13:57:33+02:00 Handle records in the renamer This patch moves the field-based logic for disambiguating record updates to the renamer. The type-directed logic, scheduled for removal, remains in the typechecker. To do this properly (and fix the myriad of bugs surrounding the treatment of duplicate record fields), we took the following main steps: 1. Create GREInfo, a renamer-level equivalent to TyThing which stores information pertinent to the renamer. This allows us to uniformly treat imported and local Names in the renamer, as described in Note [GREInfo]. 2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which distinguished between normal names and field names, we now store simple Names in GlobalRdrElt, along with the new GREInfo information which allows us to recover the FieldLabel for record fields. 3. Add namespacing for record fields, within the OccNames themselves. This allows us to remove the mangling of duplicate field selectors. This change ensures we don't print mangled names to the user in error messages, and allows us to handle duplicate record fields in Template Haskell. 4. Move record disambiguation to the renamer, and operate on the level of data constructors instead, to handle #21443. The error message text for ambiguous record updates has also been changed to reflect that type-directed disambiguation is on the way out. (3) means that OccEnv is now a bit more complex: we first key on the textual name, which gives an inner map keyed on NameSpace: OccEnv a ~ FastStringEnv (UniqFM NameSpace a) Note that this change, along with (2), both increase the memory residency of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to regress somewhat in compile-time allocation. Even though (3) simplified a lot of code (in particular the treatment of field selectors within Template Haskell and in error messages), it came with one important wrinkle: in the situation of -- M.hs-boot module M where { data A; foo :: A -> Int } -- M.hs module M where { data A = MkA { foo :: Int } } we have that M.hs-boot exports a variable foo, which is supposed to match with the record field foo that M exports. To solve this issue, we add a new impedance-matching binding to M foo{var} = foo{fld} This mimics the logic that existed already for impedance-binding DFunIds, but getting it right was a bit tricky. See Note [Record field impedance matching] in GHC.Tc.Module. We also needed to be careful to avoid introducing space leaks in GHCi. So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in ModIface. This means stubbing out all the GREInfo fields, with the function forceGlobalRdrEnv. When we read it back in, we rehydrate with rehydrateGlobalRdrEnv. This robustly avoids any space leaks caused by retaining old type environments. Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063 Updates haddock submodule ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiLayerModulesDefsGhci MultiLayerModulesNoCode T13701 T14697 hard_hole_fits ------------------------- - - - - - 4f1940f0 by sheaf at 2023-03-29T13:57:33+02:00 Avoid repeatedly shadowing in shadowNames This commit refactors GHC.Type.Name.Reader.shadowNames to first accumulate all the shadowing arising from the introduction of a new set of GREs, and then applies all the shadowing to the old GlobalRdrEnv in one go. - - - - - d246049c by sheaf at 2023-03-29T13:57:34+02:00 igre_prompt_env: discard "only-qualified" names We were unnecessarily carrying around names only available qualified in igre_prompt_env, violating the icReaderEnv invariant. We now get rid of these, as they aren't needed for the shadowing computation that igre_prompt_env exists for. Fixes #23177 ------------------------- Metric Decrease: T14052 T14052Type ------------------------- - - - - - 41a572f6 by Matthew Pickering at 2023-03-29T16:17:21-04:00 hadrian: Fix path to HpcParser.y The source for this project has been moved into a src/ folder so we also need to update this path. Fixes #23187 - - - - - b159e0e9 by doyougnu at 2023-03-30T01:40:08-04:00 js: split JMacro into JS eDSL and JS syntax This commit: Splits JExpr and JStat into two nearly identical DSLs: - GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a value cannot be unsaturated, or, a value of this DSL is a witness that a value of GHC.JS.Unsat has been saturated - GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation. Then all binary and outputable instances are changed to use GHC.JS.Syntax. This moves us closer to closing out #22736 and #22352. See #22736 for roadmap. ------------------------- Metric Increase: CoOpt_Read LargeRecord ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T10858 T11195 T11374 T11822 T12227 T12707 T13035 T13253 T13253-spj T13379 T14683 T15164 T15703 T16577 T17096 T17516 T17836 T18140 T18282 T18304 T18478 T18698a T18698b T18923 T1969 T19695 T20049 T21839c T3064 T4801 T5321FD T5321Fun T5631 T5642 T783 T9198 T9233 T9630 TcPlugin_RewritePerf WWRec ------------------------- - - - - - f4f1f14f by Sylvain Henry at 2023-03-30T01:40:49-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. Also used the opportunity to reenable 64-bit Word/Int tests - - - - - a5360490 by Ben Gamari at 2023-03-30T01:41:25-04:00 testsuite: Fix racing prints in T21465 As noted in #23155, we previously failed to add flushes necessary to ensure predictable output. Fixes #23155. - - - - - 98b5cf67 by Matthew Pickering at 2023-03-30T09:58:40+01:00 Revert "ghc-heap: remove wrong Addr# coercion (#23181)" This reverts commit f4f1f14f8009c3c120b8b963ec130cbbc774ec02. This fails to build with GHC-9.2 as a boot compiler. See #23195 for tracking this issue. - - - - - 61a2dfaa by Bodigrim at 2023-03-30T14:35:57-04:00 Add {-# WARNING #-} to Data.List.{head,tail} - - - - - 8f15c47c by Bodigrim at 2023-03-30T14:35:57-04:00 Fixes to accomodate Data.List.{head,tail} with {-# WARNING #-} - - - - - 7c7dbade by Bodigrim at 2023-03-30T14:35:57-04:00 Bump submodules - - - - - d2d8251b by Bodigrim at 2023-03-30T14:35:57-04:00 Fix tests - - - - - 3d38dcb6 by sheaf at 2023-03-30T14:35:57-04:00 Proxies for head and tail: review suggestions - - - - - 930edcfd by sheaf at 2023-03-30T14:36:33-04:00 docs: move RecordUpd changelog entry to 9.8 This was accidentally included in the 9.6 changelog instead of the 9.6 changelog. - - - - - 6f885e65 by sheaf at 2023-03-30T14:37:09-04:00 Add LANGUAGE GADTs to GHC.Rename.Env We need to enable this extension for the file to compile with ghc 9.2, as we are pattern matching on a GADT and this required the GADT extension to be enabled until 9.4. - - - - - 6d6a37a8 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: make lint-ci-config job fast again We don't pin our nixpkgs revision and tracks the default nixpkgs-unstable channel anyway. Instead of using haskell.packages.ghc924, we should be using haskell.packages.ghc92 to maximize the binary cache hit rate and make lint-ci-config job fast again. Also bumps the nix docker image to the latest revision. - - - - - ef1548c4 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: ensure that all non-i386 pipelines do parallel xz compression We can safely enable parallel xz compression for non-i386 pipelines. However, previously we didn't export XZ_OPT, so the xz process won't see it if XZ_OPT hasn't already been set in the current job. - - - - - 20432d16 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: unset CROSS_EMULATOR for js job - - - - - 4a24dbbe by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: fix lint-testsuite job The list_broken make target will transitively depend on the calibrate.out target, which used STAGE1_GHC instead of TEST_HC. It really should be TEST_HC since that's what get passed in the gitlab CI config. - - - - - cea56ccc by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: use alpine3_17-wasm image for wasm jobs Bump the ci-images dependency and use the new alpine3_17-wasm docker image for wasm jobs. - - - - - 79d0cb32 by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - e7392b4e by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Normalize away differences in ghc executable name - - - - - ee160d06 by Ben Gamari at 2023-03-30T18:43:53+00:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - 30c84511 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: don't add optllvm way for wasm32 - - - - - f1beee36 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: normalize the .wasm extension - - - - - a984a103 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: strip the cross ghc prefix in output and error message - - - - - f7478d95 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: handle target executable extension - - - - - 8fe8b653 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: mypy typing error fixes This patch fixes some mypy typing errors which weren't caught in previous linting jobs. - - - - - 0149f32f by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: use context variable instead of thread-local variable This patch changes a thread-local variable to context variable instead, which works as intended when the testsuite transitions to use asyncio & coroutines instead of multi-threading to concurrently run test cases. Note that this also raises the minimum Python version to 3.7. - - - - - ea853ff0 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: asyncify the testsuite driver This patch refactors the testsuite driver, gets rid of multi-threading logic for running test cases concurrently, and uses asyncio & coroutines instead. This is not yak shaving for its own sake; the previous multi-threading logic is prone to livelock/deadlock conditions for some reason, even if the total number of threads is bounded to a thread pool's capacity. The asyncify change is an internal implementation detail of the testsuite driver and does not impact most GHC maintainers out there. The patch does not touch the .T files, test cases can be added/modified the exact same way as before. - - - - - 0077cb22 by Matthew Pickering at 2023-03-31T21:28:28-04:00 Add test for T23184 There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj at microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 A bunch of changes related to eta reduction This is a large collection of changes all relating to eta reduction, originally triggered by #18993, but there followed a long saga. Specifics: ...lots of lines omitted... Other incidental changes * Fix a fairly long-standing outright bug in the ApplyToVal case of GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the tail of 'dmds' in the recursive call, which meant the demands were All Wrong. I have no idea why this has not caused problems before now. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes. - - - - - 62d25071 by mangoiv at 2023-04-01T04:20:01-04:00 [feat] make ($) representation polymorphic - this change was approved by the CLC in [1] following a CLC proposal [2] - make ($) representation polymorphic (adjust the type signature) - change ($) implementation to allow additional polymorphism - adjust the haddock of ($) to reflect these changes - add additional documentation to document these changes - add changelog entry - adjust tests (move now succeeding tests and adjust stdout of some tests) [1] https://github.com/haskell/core-libraries-committee/issues/132#issuecomment-1487456854 [2] https://github.com/haskell/core-libraries-committee/issues/132 - - - - - 77c33fb9 by Artem Pelenitsyn at 2023-04-01T04:20:41-04:00 User Guide: update copyright year: 2020->2023 - - - - - 3b5be05a by doyougnu at 2023-04-01T09:42:31-04:00 driver: Unit State Data.Map -> GHC.Unique.UniqMap In pursuit of #22426. The driver and unit state are major contributors. This commit also bumps the haddock submodule to reflect the API changes in UniqMap. ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp T10421 T10547 T12150 T12234 T12425 T13035 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T5837 T6048 T9198 ------------------------- - - - - - a84fba6e by Torsten Schmits at 2023-04-01T09:43:12-04:00 Add structured error messages for GHC.Tc.TyCl Tracking ticket: #20117 MR: !10183 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 6e2eb275 by doyougnu at 2023-04-01T18:27:56-04:00 JS: Linker: use saturated JExpr Follow on to MR!10142 in pursuit of #22736 - - - - - 3da69346 by sheaf at 2023-04-01T18:28:37-04:00 Improve haddocks of template-haskell Con datatype This adds a bit more information, in particular about the lists of constructors in the GadtC and RecGadtC cases. - - - - - 3b7bbb39 by sheaf at 2023-04-01T18:28:37-04:00 TH: revert changes to GadtC & RecGadtC Commit 3f374399 included a breaking-change to the template-haskell library when it made the GadtC and RecGadtC constructors take non-empty lists of names. As this has the potential to break many users' packages, we decided to revert these changes for now. - - - - - f60f6110 by Bodigrim at 2023-04-02T18:59:30-04:00 Rework documentation for data Char - - - - - 43ebd5dc by Bodigrim at 2023-04-02T19:00:09-04:00 cmm: implement parsing of MO_AtomicRMW from hand-written CMM files Fixes #23206 - - - - - ab9cd52d by Sylvain Henry at 2023-04-03T08:15:21-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. - - - - - 2b2afff3 by Matthew Pickering at 2023-04-03T08:15:58-04:00 hadrian: Update bootstrap plans for 9.2.6, 9.2.7, 9.4.4, 9.4.5, 9.6.1 Also fixes the ./generate_bootstrap_plans script which was recently broken We can hopefully drop the 9.2 plans soon but they still work so kept them around for now. - - - - - c2605e25 by Matthew Pickering at 2023-04-03T08:15:58-04:00 ci: Add job to test 9.6 bootstrapping - - - - - 53e4d513 by Krzysztof Gogolewski at 2023-04-03T08:16:35-04:00 hadrian: Improve option parsing Several options in Hadrian had their argument marked as optional (`OptArg`), but if the argument wasn't there they were just giving an error. It's more idiomatic to mark the argument as required instead; the code uses less Maybes, the parser can enforce that the argument is present, --help gives better output. - - - - - a8e36892 by Sylvain Henry at 2023-04-03T08:17:16-04:00 JS: fix issues with FD api support - Add missing implementations for fcntl_read/write/lock - Fix fdGetMode These were found while implementing TH in !9779. These functions must be used somehow by the external interpreter code. - - - - - 8b092910 by Haskell-mouse at 2023-04-03T19:31:26-04:00 Convert diagnostics in GHC.Rename.HsType to proper TcRnMessage I've turned all occurrences of TcRnUnknownMessage in GHC.Rename.HsType module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnDataKindsError TcRnUnusedQuantifiedTypeVar TcRnIllegalKindSignature TcRnUnexpectedPatSigType TcRnSectionPrecedenceError TcRnPrecedenceParsingError TcRnIllegalKind TcRnNegativeNumTypeLiteral TcRnUnexpectedKindVar TcRnBindMultipleVariables TcRnBindVarAlreadyInScope - - - - - 220a7a48 by Krzysztof Gogolewski at 2023-04-03T19:32:02-04:00 Fixes around unsafeCoerce# 1. `unsafeCoerce#` was documented in `GHC.Prim`. But since the overhaul in 74ad75e87317, `unsafeCoerce#` is no longer defined there. I've combined the documentation in `GHC.Prim` with the `Unsafe.Coerce` module. 2. The documentation of `unsafeCoerce#` stated that you should not cast a function to an algebraic type, even if you later cast it back before applying it. But ghci was doing that type of cast, as can be seen with 'ghci -ddump-ds' and typing 'x = not'. I've changed it to use Any following the documentation. - - - - - 9095e297 by Matthew Craven at 2023-04-04T01:04:10-04:00 Add a few more memcpy-ish primops * copyMutableByteArrayNonOverlapping# * copyAddrToAddr# * copyAddrToAddrNonOverlapping# * setAddrRange# The implementations of copyBytes, moveBytes, and fillBytes in base:Foreign.Marshal.Utils now use these new primops, which can cause us to work a bit harder generating code for them, resulting in the metric increase in T21839c observed by CI on some architectures. But in exchange, we get better code! Metric Increase: T21839c - - - - - f7da530c by Matthew Craven at 2023-04-04T01:04:10-04:00 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. - - - - - cd00e321 by sheaf at 2023-04-04T01:04:50-04:00 Relax assertion in varToRecFieldOcc When using Template Haskell, it is possible to re-parent a field OccName belonging to one data constructor to another data constructor. The lsp-types package did this in order to "extend" a data constructor with additional fields. This ran into an assertion in 'varToRecFieldOcc'. This assertion can simply be relaxed, as the resulting splices are perfectly sound. Fixes #23220 - - - - - eed0d930 by Sylvain Henry at 2023-04-04T11:09:15-04:00 GHCi.RemoteTypes: fix doc and avoid unsafeCoerce (#23201) - - - - - 071139c3 by Ryan Scott at 2023-04-04T11:09:51-04:00 Make INLINE pragmas for pattern synonyms work with TH Previously, the code for converting `INLINE <name>` pragmas from TH splices used `vNameN`, which assumed that `<name>` must live in the variable namespace. Pattern synonyms, on the other hand, live in the constructor namespace. I've fixed the issue by switching to `vcNameN` instead, which works for both the variable and constructor namespaces. Fixes #23203. - - - - - 7c16f3be by Krzysztof Gogolewski at 2023-04-04T17:13:00-04:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). - - - - - c165f079 by sheaf at 2023-04-04T17:13:40-04:00 Add testcase for #23192 This issue around solving of constraints arising from superclass expansion using other constraints also borned from superclass expansion was the topic of commit aed1974e. That commit made sure we don't emit a "redundant constraint" warning in a situation in which removing the constraint would cause errors. Fixes #23192 - - - - - d1bb16ed by Ben Gamari at 2023-04-06T03:40:45-04:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 - - - - - 04b80850 by Brandon Chinn at 2023-04-06T03:41:21-04:00 Fix reverse flag for -Wunsupported-llvm-version - - - - - 0c990e13 by Pierre Le Marre at 2023-04-06T10:16:29+00:00 Add release note for GHC.Unicode refactor in base-4.18. Also merge CLC proposal 130 in base-4.19 with CLC proposal 59 in base-4.18 and add proper release date. - - - - - cbbfb283 by Alex Dixon at 2023-04-07T18:27:45-04:00 Improve documentation for ($) (#22963) - - - - - 5193c2b0 by Alex Dixon at 2023-04-07T18:27:45-04:00 Remove trailing whitespace from ($) commentary - - - - - b384523b by Sebastian Graf at 2023-04-07T18:27:45-04:00 Adjust wording wrt representation polymorphism of ($) - - - - - 6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00 Add structured error messages for GHC.Tc.TyCl.Utils Tracking ticket: #20117 MR: !10251 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00 Renamer: don't call addUsedGRE on an exact Name When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc, we could end up calling addUsedGRE on an exact Name, which would then lead to a panic in the bestImport function: it would be incapable of processing a GRE which is not local but also not brought into scope by any imports (as it is referred to by its unique instead). Fixes #23240 - - - - - bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00 Set base 'maintainer' field to CLC - - - - - ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00 Clarify a couple of Notes about 'nospec' - - - - - ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - ae696831 by Ben Gamari at 2023-05-08T10:06:23+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/generate_job_metadata - .gitlab/generate_jobs - .gitlab/jobs.yaml - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - .gitlab/rel_eng/upload_ghc_libs.py - .gitlab/test-metrics.sh - .gitmodules - CODEOWNERS - cabal.project-reinstall - compile_flags.txt - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/534b46b51175aa06d7db199316bd866298159a32...ae696831d39a288c0f4849e4f93dfed117e2092b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/534b46b51175aa06d7db199316bd866298159a32...ae696831d39a288c0f4849e4f93dfed117e2092b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 10:45:49 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Mon, 08 May 2023 06:45:49 -0400 Subject: [Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328) Message-ID: <6458d2ddaad5_38ffda3919fb8428484d@gitlab.mail> Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC Commits: 47e635e7 by Josh Meredith at 2023-05-08T10:45:33+00:00 JS: refactor jsSaturate to return a saturated JStat (#23328) - - - - - 9 changed files: - compiler/GHC/JS/Transform.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/CoreUtils.hs - compiler/GHC/StgToJS/DataCon.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Monad.hs - compiler/GHC/StgToJS/Rts/Rts.hs Changes: ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -6,13 +6,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform ( identsS , identsV , identsE -- * Saturation - , jsSaturate + , satJStat + , satJExpr -- * Generic traversal (via compos) , JMacro(..) , JMGadt(..) @@ -21,8 +23,6 @@ module GHC.JS.Transform , composOpM , composOpM_ , composOpFold - , satJExpr - , satJStat ) where @@ -33,11 +33,12 @@ import GHC.JS.Unsat.Syntax import Data.Functor.Identity import Control.Monad -import Control.Arrow ((***)) +import Data.List (sortBy) import GHC.Data.FastString import GHC.Utils.Monad.State.Strict import GHC.Types.Unique.Map +import GHC.Types.Unique.FM {-# INLINE identsS #-} @@ -200,66 +201,59 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) +satJStat :: Maybe FastString -> JStat -> Sat.JStat +satJStat str x = evalState (jsSaturateS x) (newIdentSupply str) + +satJExpr :: Maybe FastString -> JExpr -> Sat.JExpr +satJExpr str x = evalState (jsSaturateE x) (newIdentSupply str) + +jsSaturateS :: JStat -> State [Ident] Sat.JStat +jsSaturateS = \case + DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs + ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e + IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e + WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e + ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body + SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct + <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps + <*> jsSaturateS def + TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f + BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs + ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand + UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand + AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> jsSaturateE rhs + LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt + BreakStat m_l -> return $ Sat.BreakStat $! m_l + ContinueStat m_l -> return $ Sat.ContinueStat $! m_l + UnsatBlock us -> jsSaturateS =<< runIdentSupply us + +jsSaturateE :: JExpr -> State [Ident] Sat.JExpr +jsSaturateE = \case + ValExpr v -> Sat.ValExpr <$> jsSaturateV v + SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i + IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i + InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r + UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r + IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e + ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands + UnsatExpr us -> jsSaturateE =<< runIdentSupply us + +jsSaturateV :: JVal -> State [Ident] Sat.JVal +jsSaturateV = \case + JVar i -> return $ Sat.JVar i + JList xs -> Sat.JList <$> mapM jsSaturateE xs + JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) + JInt i -> return $ Sat.JInt i + JStr s -> return $ Sat.JStr s + JRegEx f -> return $ Sat.JRegEx f + JHash m -> Sat.JHash <$> mapUniqMapM satHash m where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v - - --------------------------------------------------------------------------------- --- Translation --- --- This will be moved after GHC.JS.Syntax is removed --------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing - - -- This is an Applicative but we can't use it because no type variables :( - witness :: JStat -> Sat.JStat - witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) - witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) - witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) - witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) - witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i - (satJExpr iter) - (witness body) - witness (SwitchStat struct ps def) = Sat.SwitchStat - (satJExpr struct) - (map (satJExpr *** witness) ps) - (witness def) - witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) - witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs - witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) - witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) - witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) - witness (BreakStat Nothing) = Sat.BreakStat Nothing - witness (BreakStat (Just l)) = Sat.BreakStat $! Just l - witness (ContinueStat Nothing) = Sat.ContinueStat Nothing - witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l - witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" - - -satJExpr :: JExpr -> Sat.JExpr -satJExpr = go - where - go (ValExpr v) = Sat.ValExpr (satJVal v) - go (SelExpr obj i) = Sat.SelExpr (satJExpr obj) i - go (IdxExpr o i) = Sat.IdxExpr (satJExpr o) (satJExpr i) - go (InfixExpr op l r) = Sat.InfixExpr (satJOp op) (satJExpr l) (satJExpr r) - go (UOpExpr op r) = Sat.UOpExpr (satJUOp op) (satJExpr r) - go (IfExpr c t e) = Sat.IfExpr (satJExpr c) (satJExpr t) (satJExpr e) - go (ApplExpr rator rands) = Sat.ApplExpr (satJExpr rator) (satJExpr <$> rands) - go UnsatExpr{} = error "satJExpr: discovered an Unsat...impossibly" + satHash (i, x) = (i,) . (i,) <$> jsSaturateE x + compareHash (i,_) (j,_) = lexicalCompareFS i j + -- By lexically sorting the elements, the non-determinism introduced by nonDetEltsUFM is avoided + mapUniqMapM f (UniqMap m) = UniqMap . listToUFM <$> (mapM f . sortBy compareHash $ nonDetEltsUFM m) + JFunc args body -> Sat.JFunc args <$> jsSaturateS body + UnsatVal us -> jsSaturateV =<< runIdentSupply us satJOp :: JOp -> Sat.Op satJOp = go @@ -305,15 +299,3 @@ satJUOp = go go PreDecOp = Sat.PreDecOp go PostDecOp = Sat.PostDecOp -satJVal :: JVal -> Sat.JVal -satJVal = go - where - go (JVar i) = Sat.JVar i - go (JList xs) = Sat.JList (satJExpr <$> xs) - go (JDouble d) = Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) - go (JInt i) = Sat.JInt i - go (JStr f) = Sat.JStr f - go (JRegEx f) = Sat.JRegEx f - go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) - go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -134,8 +134,7 @@ genUnits m ss spt_entries foreign_stubs = do staticInit <- initStaticPtrs spt_entries let stat = ( -- O.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m 1) + satJStat (Just $ modulePrefix m 1) $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] let oi = ObjUnit @@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = satJStat (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -246,8 +245,7 @@ genUnits m ss spt_entries foreign_stubs = do topDeps = collectTopIds decl required = hasExport decl stat = -- Opt.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m n) + satJStat (Just $ modulePrefix m n) $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps let oi = ObjUnit @@ -336,7 +334,7 @@ genToplevelRhs i rhs = case rhs of eid@(TxtI eidt) <- identForEntryId i (TxtI idt) <- identForId i body <- genBody (initExprCtx i) R2 args body typ - global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body) + global_occs <- globalOccs (satJStat (Just "ghcjs_tmp_sat_") body) let lidents = map global_ident global_occs let lids = map global_id global_occs let lidents' = map identFS lidents ===================================== compiler/GHC/StgToJS/CoreUtils.hs ===================================== @@ -253,7 +253,7 @@ assocPrimReps (r:rs) vs = case (primRepSize r,vs) of (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs - err -> pprPanic "assocPrimReps" (ppr $ fmap (map satJExpr) $ err) + err -> pprPanic "assocPrimReps" (ppr $ map (satJExpr Nothing) <$> err) -- | Associate the given values to the Id's PrimReps, taking into account the -- number of slots per PrimRep ===================================== compiler/GHC/StgToJS/DataCon.hs ===================================== @@ -60,8 +60,8 @@ genCon ctx con args | xs <- concatMap typex_expr (ctxTarget ctx) = pprPanic "genCon: unhandled DataCon" (ppr (con - , fmap satJExpr args - , fmap satJExpr xs + , satJExpr Nothing <$> args + , satJExpr Nothing <$> xs )) -- | Allocate a data constructor. Allocate in this context means bind the data @@ -90,7 +90,7 @@ allocUnboxedCon con = \case | isBoolDataCon con && dataConTag con == 2 -> true_ [x] | isUnboxableCon con -> x - xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, fmap satJExpr xs)) + xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, satJExpr Nothing <$> xs)) -- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -900,7 +900,7 @@ caseCond = \case DataAlt da -> return $ Just (toJExpr $ dataConTag da) LitAlt l -> genLit l >>= \case [e] -> pure (Just e) - es -> pprPanic "caseCond: expected single-variable literal" (ppr $ fmap satJExpr es) + es -> pprPanic "caseCond: expected single-variable literal" (ppr $ satJExpr Nothing <$> es) -- fixme use single tmp var for all branches -- | Load parameters from constructor ===================================== compiler/GHC/StgToJS/FFI.hs ===================================== @@ -14,6 +14,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Arg import GHC.StgToJS.ExprCtx @@ -176,8 +177,8 @@ genFFIArg isJavaScriptCc a@(StgVarArg i) arg_ty = stgArgType a r = uTypeVt arg_ty -saturateFFI :: JMacro a => Int -> a -> a -saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) +saturateFFI :: Int -> JStat -> Sat.JStat +saturateFFI u = satJStat (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) genForeignCall :: HasDebugCallStack => ExprCtx ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (satJStat Nothing meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Monad.hs ===================================== @@ -25,6 +25,7 @@ where import GHC.Prelude import GHC.JS.Unsat.Syntax +import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform import GHC.StgToJS.Types @@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc -- | Return number of occurrences of every global id used in the given JStat. -- Sort by increasing occurrence count. -globalOccs :: JStat -> G [GlobalOcc] +globalOccs :: Sat.JStat -> G [GlobalOcc] globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache -- build a map form Ident Unique to (Ident, Id, Count) @@ -180,4 +181,4 @@ globalOccs jst = do let g = GlobalOcc i gid 1 in go (addToUFM_C inc gids i g) is - pure $ go emptyUFM (identsS $ satJStat jst) + pure $ go emptyUFM (identsS jst) ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Apply import GHC.StgToJS.Closure @@ -298,8 +299,8 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat -rtsDecls = jsSaturate (Just "h$RTSD") $ +rtsDecls :: Sat.JStat +rtsDecls = satJStat (Just "h$RTSD") $ mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread , TxtI "h$stack" ||= null_ -- stack for the current thread , TxtI "h$sp" ||= 0 -- stack pointer for the current thread @@ -314,15 +315,15 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat -rts = jsSaturate (Just "h$RTS") . rts' +rts :: StgToJSConfig -> Sat.JStat +rts = satJStat (Just "h$RTS") . rts' -- | JS Payload which defines the embedded RTS. rts' :: StgToJSConfig -> JStat View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47e635e7b1a24e359ddd914086757b6b6640cc7c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47e635e7b1a24e359ddd914086757b6b6640cc7c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 10:53:24 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Mon, 08 May 2023 06:53:24 -0400 Subject: [Git][ghc/ghc][wip/unboxed-codebuffer] 69 commits: Convert interface file loading errors into proper diagnostics Message-ID: <6458d4a4913e_38ffda3a5a2078294781@gitlab.mail> Josh Meredith pushed to branch wip/unboxed-codebuffer at Glasgow Haskell Compiler / GHC Commits: 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - a630796b by Josh Meredith at 2023-05-08T10:49:53+00:00 Replace the implementation of CodeBuffers with unboxed types - - - - - f0270a3e by Josh Meredith at 2023-05-08T10:49:53+00:00 Use unboxed codebuffers in base - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Config/Diagnostic.hs - compiler/GHC/Driver/Config/Tidy.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - + compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eb1588f66317282deeaf3d3910c17b25b8ff6b0b...f0270a3eea9892bfa80757538ed9e332383366e0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eb1588f66317282deeaf3d3910c17b25b8ff6b0b...f0270a3eea9892bfa80757538ed9e332383366e0 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 11:17:58 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 07:17:58 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] ROMES: WIP Message-ID: <6458da66f1706_38ffda3cf94c50308720@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: e0c7fdc8 by Rodrigo Mesquita at 2023-05-08T12:17:50+01:00 ROMES: WIP - - - - - 20 changed files: - hadrian/cfg/system.config.in - hadrian/src/Hadrian/Oracles/TextFile.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Builders/RunTest.hs - m4/fp_settings.m4 - m4/ghc_toolchain.m4 - utils/ghc-toolchain/src/GHC/Toolchain/Program.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Nm.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ranlib.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Readelf.hs Changes: ===================================== hadrian/cfg/system.config.in ===================================== @@ -131,6 +131,7 @@ conf-merge-objects-args-stage3 = @MergeObjsArgs@ # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] +gcc-extra-via-c-opts = @GccExtraViaCOpts@ ld-has-no-compact-unwind = @LdHasNoCompactUnwind@ ld-has-filelist = @LdHasFilelist@ ld-supports-response-files = @LdSupportsResponseFiles@ ===================================== hadrian/src/Hadrian/Oracles/TextFile.hs ===================================== @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Orphan instances for Toolchain.Target {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Hadrian.Oracles.TextFile @@ -13,7 +15,8 @@ module Hadrian.Oracles.TextFile ( lookupValue, lookupValueOrEmpty, lookupValueOrError, lookupSystemConfig, lookupValues, lookupValuesOrEmpty, lookupValuesOrError, lookupDependencies, textFileOracle, - getHostTargetConfig, getTargetTargetConfig + getHostTargetConfig, getTargetTargetConfig, + queryHostTargetConfig, queryTargetTargetConfig ) where import Control.Monad @@ -97,6 +100,12 @@ getHostTargetConfig = getTargetConfig hostTargetFile getTargetTargetConfig :: Action Toolchain.Target getTargetTargetConfig = getTargetConfig targetTargetFile +queryHostTargetConfig :: (Toolchain.Target -> String) -> Action String +queryHostTargetConfig f = f <$> getHostTargetConfig + +queryTargetTargetConfig :: (Toolchain.Target -> String) -> Action String +queryTargetTargetConfig f = f <$> getTargetTargetConfig + newtype KeyValue = KeyValue (FilePath, String) deriving (Binary, Eq, Hashable, NFData, Show, Typeable) type instance RuleResult KeyValue = Maybe String @@ -143,21 +152,16 @@ textFileOracle = do putVerbose $ "| TargetFile oracle: reading " ++ quote file ++ "..." target <- read <$> readFile' file return (target :: Toolchain.Target) - void $ addOracle $ \(TargetFile file) -> tf file + void $ addOracleCache $ \(TargetFile file) -> tf file --- ROMES:TODO: get back to this!!!!!! -instance Eq Toolchain.Target where - (==) _ _ = True +-- Orphan instances for (ShakeValue Toolchain.Target) +instance Binary Toolchain.Target where + put = put . show + get = read <$> get -instance Ord Toolchain.Target where - (<=) _ _ = False instance Hashable Toolchain.Target where - hashWithSalt _ _ = 0 -instance Binary Toolchain.Target where - put _ = undefined - get = undefined + hashWithSalt s = hashWithSalt s . show instance NFData Toolchain.Target where - rnf _ = () - + rnf = flip seq () -- ROMES:TODO: Is this a good enough instance? ===================================== hadrian/src/Oracles/Flag.hs ===================================== @@ -55,6 +55,9 @@ data FlagKey = SystemConfigKey String -- fragile, but some flags do behave like this. flag :: Flag -> Action Bool flag f = do + -- ROMES:TODO: Use queryToolchainConfig directly, which perhaps allows us + -- to get rid of the Oracle for the whole toolchain, which requires weak + -- orphan instances. let flagkey :: FlagKey = case f of ArSupportsAtFile -> TargetTargetKey (Toolchain.arSupportsAtFile . tgtAr) ArSupportsDashL -> TargetTargetKey (Toolchain.arSupportsDashL . tgtAr) @@ -100,7 +103,7 @@ getFlag = expr . flag -- when appropriate). platformSupportsGhciObjects :: Action Bool platformSupportsGhciObjects = - not . null <$> settingsFileSetting SettingsFileSetting_MergeObjectsCommand + not . null <$> settingsFileSetting ToolchainSetting_MergeObjectsCommand arSupportsDashL :: Stage -> Action Bool arSupportsDashL (Stage0 {}) = flag SystemArSupportsDashL ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -3,7 +3,7 @@ module Oracles.Setting ( -- * Settings Setting (..), SettingList (..), setting, settingList, getSetting, getSettingList, - SettingsFileSetting (..), settingsFileSetting, + ToolchainSetting (..), settingsFileSetting, -- * Helpers ghcCanonVersion, cmdLineLengthLimit, hostSupportsRPaths, topDirectory, @@ -23,6 +23,9 @@ import Hadrian.Oracles.Path import Base +import GHC.Toolchain +import GHC.Toolchain.Program + -- | Each 'Setting' comes from the file @hadrian/cfg/system.config@, generated -- by the @configure@ script from the input file @hadrian/cfg/system.config.in at . -- For example, the line @@ -103,32 +106,32 @@ data SettingList = ConfCcArgs Stage -- from aclocal.m4 whenever they can be calculated from other variables -- already fed into Hadrian. --- | Each 'SettingsFileSetting' is defined by 'FP_SETTINGS' in aclocal.m4. --- Eventually much of that local can probably be computed just in Hadrian. -data SettingsFileSetting - = SettingsFileSetting_CCompilerCommand - | SettingsFileSetting_CxxCompilerCommand - | SettingsFileSetting_HaskellCPPCommand - | SettingsFileSetting_HaskellCPPFlags - | SettingsFileSetting_CCompilerFlags - | SettingsFileSetting_CxxCompilerFlags - | SettingsFileSetting_CCompilerLinkFlags - | SettingsFileSetting_CCompilerSupportsNoPie - | SettingsFileSetting_LdCommand - | SettingsFileSetting_LdFlags - | SettingsFileSetting_MergeObjectsCommand - | SettingsFileSetting_MergeObjectsFlags - | SettingsFileSetting_ArCommand - | SettingsFileSetting_RanlibCommand - | SettingsFileSetting_OtoolCommand - | SettingsFileSetting_InstallNameToolCommand - | SettingsFileSetting_DllWrapCommand - | SettingsFileSetting_WindresCommand - | SettingsFileSetting_TouchCommand - | SettingsFileSetting_ClangCommand - | SettingsFileSetting_LlcCommand - | SettingsFileSetting_OptCommand - | SettingsFileSetting_DistroMinGW +-- | All 'ToolchainSetting's are computed by the ghc-toolchain utility for configuring toolchains. +-- This used to be defined by 'FP_SETTINGS' in aclocal.m4. +data ToolchainSetting + = ToolchainSetting_CCompilerCommand + | ToolchainSetting_CxxCompilerCommand + | ToolchainSetting_HaskellCPPCommand + | ToolchainSetting_HaskellCPPFlags + | ToolchainSetting_CCompilerFlags + | ToolchainSetting_CxxCompilerFlags + | ToolchainSetting_CCompilerLinkFlags + | ToolchainSetting_CCompilerSupportsNoPie + | ToolchainSetting_LdCommand + | ToolchainSetting_LdFlags + | ToolchainSetting_MergeObjectsCommand + | ToolchainSetting_MergeObjectsFlags + | ToolchainSetting_ArCommand + | ToolchainSetting_RanlibCommand + | ToolchainSetting_OtoolCommand + | ToolchainSetting_InstallNameToolCommand + | ToolchainSetting_DllWrapCommand + | ToolchainSetting_WindresCommand + | ToolchainSetting_TouchCommand + | ToolchainSetting_ClangCommand + | ToolchainSetting_LlcCommand + | ToolchainSetting_OptCommand + | ToolchainSetting_DistroMinGW -- | Look up the value of a 'Setting' in @cfg/system.config@, tracking the -- result. @@ -202,31 +205,36 @@ settingList key = fmap words $ lookupSystemConfig $ case key of -- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the -- result. -- See Note [tooldir: How GHC finds mingw on Windows] -settingsFileSetting :: SettingsFileSetting -> Action String -settingsFileSetting key = lookupSystemConfig $ case key of - SettingsFileSetting_CCompilerCommand -> "settings-c-compiler-command" - SettingsFileSetting_CxxCompilerCommand -> "settings-cxx-compiler-command" - SettingsFileSetting_HaskellCPPCommand -> "settings-haskell-cpp-command" - SettingsFileSetting_HaskellCPPFlags -> "settings-haskell-cpp-flags" - SettingsFileSetting_CCompilerFlags -> "settings-c-compiler-flags" - SettingsFileSetting_CxxCompilerFlags -> "settings-cxx-compiler-flags" - SettingsFileSetting_CCompilerLinkFlags -> "settings-c-compiler-link-flags" - SettingsFileSetting_CCompilerSupportsNoPie -> "settings-c-compiler-supports-no-pie" - SettingsFileSetting_LdCommand -> "settings-ld-command" - SettingsFileSetting_LdFlags -> "settings-ld-flags" - SettingsFileSetting_MergeObjectsCommand -> "settings-merge-objects-command" - SettingsFileSetting_MergeObjectsFlags -> "settings-merge-objects-flags" - SettingsFileSetting_ArCommand -> "settings-ar-command" - SettingsFileSetting_RanlibCommand -> "settings-ranlib-command" - SettingsFileSetting_OtoolCommand -> "settings-otool-command" - SettingsFileSetting_InstallNameToolCommand -> "settings-install_name_tool-command" - SettingsFileSetting_DllWrapCommand -> "settings-dll-wrap-command" - SettingsFileSetting_WindresCommand -> "settings-windres-command" - SettingsFileSetting_TouchCommand -> "settings-touch-command" - SettingsFileSetting_ClangCommand -> "settings-clang-command" - SettingsFileSetting_LlcCommand -> "settings-llc-command" - SettingsFileSetting_OptCommand -> "settings-opt-command" - SettingsFileSetting_DistroMinGW -> "settings-use-distro-mingw" +settingsFileSetting :: ToolchainSetting -> Action String +settingsFileSetting key = case key of + ToolchainSetting_CCompilerCommand -> queryHostTargetConfig (cmd . ccProgram . tgtCCompiler) + ToolchainSetting_CxxCompilerCommand -> queryHostTargetConfig (cmd . cxxProgram . tgtCxxCompiler) + ToolchainSetting_HaskellCPPCommand -> queryHostTargetConfig (cmd . cppProgram . tgtCPreprocessor) + ToolchainSetting_HaskellCPPFlags -> queryHostTargetConfig (flags . cppProgram . tgtCPreprocessor) + ToolchainSetting_CCompilerFlags -> queryHostTargetConfig (flags . ccProgram . tgtCCompiler) + ToolchainSetting_CxxCompilerFlags -> queryHostTargetConfig (flags . cxxProgram . tgtCxxCompiler) + ToolchainSetting_CCompilerLinkFlags -> queryHostTargetConfig (flags . ccLinkProgram . tgtCCompilerLink) + ToolchainSetting_CCompilerSupportsNoPie -> queryHostTargetConfig (yesNo . ccLinkSupportsNoPie . tgtCCompilerLink) + -- ROMES:TODO: What's the difference between the Ld and CCLink? + ToolchainSetting_LdCommand -> lookupSystemConfig "settings-ld-command" + ToolchainSetting_LdFlags -> lookupSystemConfig "settings-ld-flags" + ToolchainSetting_MergeObjectsCommand -> queryHostTargetConfig (maybe "" (cmd . mergeObjsProgram) . tgtMergeObjs) + ToolchainSetting_MergeObjectsFlags -> queryHostTargetConfig (maybe "" (flags . mergeObjsProgram) . tgtMergeObjs) + ToolchainSetting_ArCommand -> queryHostTargetConfig (cmd . arMkArchive . tgtAr) + ToolchainSetting_RanlibCommand -> queryHostTargetConfig (maybe "" (cmd . ranlibProgram) . tgtRanlib) + ToolchainSetting_OtoolCommand -> lookupSystemConfig "settings-otool-command" + ToolchainSetting_InstallNameToolCommand -> lookupSystemConfig "settings-install_name_tool-command" + ToolchainSetting_DllWrapCommand -> queryHostTargetConfig (maybe "" cmd . tgtDllwrap) + ToolchainSetting_WindresCommand -> queryHostTargetConfig (maybe "" cmd . tgtWindres) + ToolchainSetting_TouchCommand -> lookupSystemConfig "settings-touch-command" + ToolchainSetting_ClangCommand -> lookupSystemConfig "settings-clang-command" + ToolchainSetting_LlcCommand -> lookupSystemConfig "settings-llc-command" + ToolchainSetting_OptCommand -> lookupSystemConfig "settings-opt-command" + -- ROMES:TODO: affter handling DistroMinGW and aboves in ghc-toolchain, factor queryHostTargetConfig out + ToolchainSetting_DistroMinGW -> lookupSystemConfig "settings-use-distro-mingw" -- ROMES:TODO: This option doesn't seem to be in ghc-toolchain yet + where + flags = unwords . prgFlags + cmd = prgPath -- | An expression that looks up the value of a 'Setting' in @cfg/system.config@, -- tracking the result. ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -9,7 +9,7 @@ import qualified Data.Set as Set import Base import qualified Context import Expression -import Hadrian.Oracles.TextFile (lookupSystemConfig) +import Hadrian.Oracles.TextFile (lookupSystemConfig, queryHostTargetConfig) import Oracles.Flag import Oracles.ModuleFiles import Oracles.Setting @@ -21,6 +21,9 @@ import Settings import Target import Utilities +import qualified GHC.Toolchain as Toolchain +import GHC.Toolchain.Program (prgFlags) + -- | Track this file to rebuild generated files whenever it changes. trackGenerateHs :: Expr () trackGenerateHs = expr $ need [sourcePath -/- "Rules/Generate.hs"] @@ -411,32 +414,32 @@ generateSettings = do ctx <- getContext settings <- traverse sequence $ [ ("GCC extra via C opts", expr $ lookupSystemConfig "gcc-extra-via-c-opts") - , ("C compiler command", expr $ settingsFileSetting SettingsFileSetting_CCompilerCommand) - , ("C compiler flags", expr $ settingsFileSetting SettingsFileSetting_CCompilerFlags) - , ("C++ compiler command", expr $ settingsFileSetting SettingsFileSetting_CxxCompilerCommand) - , ("C++ compiler flags", expr $ settingsFileSetting SettingsFileSetting_CxxCompilerFlags) - , ("C compiler link flags", expr $ settingsFileSetting SettingsFileSetting_CCompilerLinkFlags) - , ("C compiler supports -no-pie", expr $ settingsFileSetting SettingsFileSetting_CCompilerSupportsNoPie) - , ("Haskell CPP command", expr $ settingsFileSetting SettingsFileSetting_HaskellCPPCommand) - , ("Haskell CPP flags", expr $ settingsFileSetting SettingsFileSetting_HaskellCPPFlags) - , ("ld command", expr $ settingsFileSetting SettingsFileSetting_LdCommand) - , ("ld flags", expr $ settingsFileSetting SettingsFileSetting_LdFlags) + , ("C compiler command", expr $ settingsFileSetting ToolchainSetting_CCompilerCommand) + , ("C compiler flags", expr $ settingsFileSetting ToolchainSetting_CCompilerFlags) + , ("C++ compiler command", expr $ settingsFileSetting ToolchainSetting_CxxCompilerCommand) + , ("C++ compiler flags", expr $ settingsFileSetting ToolchainSetting_CxxCompilerFlags) + , ("C compiler link flags", expr $ settingsFileSetting ToolchainSetting_CCompilerLinkFlags) + , ("C compiler supports -no-pie", expr $ settingsFileSetting ToolchainSetting_CCompilerSupportsNoPie) + , ("Haskell CPP command", expr $ settingsFileSetting ToolchainSetting_HaskellCPPCommand) + , ("Haskell CPP flags", expr $ settingsFileSetting ToolchainSetting_HaskellCPPFlags) + , ("ld command", expr $ settingsFileSetting ToolchainSetting_LdCommand) + , ("ld flags", expr $ settingsFileSetting ToolchainSetting_LdFlags) , ("ld supports compact unwind", expr $ lookupSystemConfig "ld-has-no-compact-unwind") , ("ld supports filelist", expr $ lookupSystemConfig "ld-has-filelist") , ("ld supports response files", expr $ lookupSystemConfig "ld-supports-response-files") , ("ld is GNU ld", expr $ lookupSystemConfig "ld-is-gnu-ld") - , ("Merge objects command", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsCommand) - , ("Merge objects flags", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsFlags) - , ("ar command", expr $ settingsFileSetting SettingsFileSetting_ArCommand) - , ("ar flags", expr $ lookupSystemConfig "ar-args") + , ("Merge objects command", expr $ settingsFileSetting ToolchainSetting_MergeObjectsCommand) + , ("Merge objects flags", expr $ settingsFileSetting ToolchainSetting_MergeObjectsFlags) + , ("ar command", expr $ settingsFileSetting ToolchainSetting_ArCommand) + , ("ar flags", expr $ queryHostTargetConfig (unwords . prgFlags . Toolchain.arMkArchive . Toolchain.tgtAr)) , ("ar supports at file", expr $ yesNo <$> flag ArSupportsAtFile) , ("ar supports -L", expr $ yesNo <$> flag ArSupportsDashL) - , ("ranlib command", expr $ settingsFileSetting SettingsFileSetting_RanlibCommand) - , ("otool command", expr $ settingsFileSetting SettingsFileSetting_OtoolCommand) - , ("install_name_tool command", expr $ settingsFileSetting SettingsFileSetting_InstallNameToolCommand) - , ("touch command", expr $ settingsFileSetting SettingsFileSetting_TouchCommand) - , ("dllwrap command", expr $ settingsFileSetting SettingsFileSetting_DllWrapCommand) - , ("windres command", expr $ settingsFileSetting SettingsFileSetting_WindresCommand) + , ("ranlib command", expr $ settingsFileSetting ToolchainSetting_RanlibCommand) + , ("otool command", expr $ settingsFileSetting ToolchainSetting_OtoolCommand) + , ("install_name_tool command", expr $ settingsFileSetting ToolchainSetting_InstallNameToolCommand) + , ("touch command", expr $ settingsFileSetting ToolchainSetting_TouchCommand) + , ("dllwrap command", expr $ settingsFileSetting ToolchainSetting_DllWrapCommand) + , ("windres command", expr $ settingsFileSetting ToolchainSetting_WindresCommand) , ("unlit command", ("$topdir/bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) , ("cross compiling", expr $ yesNo <$> flag CrossCompiling) , ("target platform string", getSetting TargetPlatform) @@ -451,10 +454,10 @@ generateSettings = do , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) , ("LLVM target", getSetting LlvmTarget) - , ("LLVM llc command", expr $ settingsFileSetting SettingsFileSetting_LlcCommand) - , ("LLVM opt command", expr $ settingsFileSetting SettingsFileSetting_OptCommand) - , ("LLVM clang command", expr $ settingsFileSetting SettingsFileSetting_ClangCommand) - , ("Use inplace MinGW toolchain", expr $ settingsFileSetting SettingsFileSetting_DistroMinGW) + , ("LLVM llc command", expr $ settingsFileSetting ToolchainSetting_LlcCommand) + , ("LLVM opt command", expr $ settingsFileSetting ToolchainSetting_OptCommand) + , ("LLVM clang command", expr $ settingsFileSetting ToolchainSetting_ClangCommand) + , ("Use inplace MinGW toolchain", expr $ settingsFileSetting ToolchainSetting_DistroMinGW) , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter) , ("Support SMP", expr $ yesNo <$> targetSupportsSMP) ===================================== hadrian/src/Rules/Test.hs ===================================== @@ -229,8 +229,8 @@ testRules = do [ "--interactive", "-v0", "-ignore-dot-ghci" , "-fno-ghci-history" ] - ccPath <- settingsFileSetting SettingsFileSetting_CCompilerCommand - ccFlags <- settingsFileSetting SettingsFileSetting_CCompilerFlags + ccPath <- settingsFileSetting ToolchainSetting_CCompilerCommand + ccFlags <- settingsFileSetting ToolchainSetting_CCompilerFlags pythonPath <- builderPath Python ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -124,7 +124,7 @@ inTreeCompilerArgs stg = do platform <- setting TargetPlatform wordsize <- (show @Int . (*8) . read) <$> setting TargetWordSize - llc_cmd <- settingsFileSetting SettingsFileSetting_LlcCommand + llc_cmd <- settingsFileSetting ToolchainSetting_LlcCommand have_llvm <- liftIO (isJust <$> findExecutable llc_cmd) top <- topDirectory ===================================== m4/fp_settings.m4 ===================================== @@ -1,6 +1,7 @@ # FP_SETTINGS # ---------------------------------- # Set the variables used in the settings file +# ROMES:TODO: Make this file obsolete AC_DEFUN([FP_SETTINGS], [ SettingsUseDistroMINGW="$EnableDistroToolchain" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -14,7 +14,7 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], -ilibraries/ghc-boot -iutils/ghc-toolchain/src \ -XNoImplicitPrelude \ -odir actmp-ghc-toolchain -hidir actmp-ghc-toolchain \ - Main -o acghc-toolchain + utils/ghc-toolchain/Main.hs -o acghc-toolchain rm -f acargs echo "--triple=$target" >> acargs ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Program.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Toolchain.Utils data Program = Program { prgPath :: FilePath , prgFlags :: [String] } - deriving (Show, Read) + deriving (Show, Read, Eq, Ord) _prgPath :: Lens Program FilePath _prgPath = Lens prgPath (\x o -> o {prgPath = x}) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -15,10 +15,10 @@ import GHC.Toolchain.Tools.Nm import GHC.Toolchain.Tools.MergeObjs data WordSize = WS4 | WS8 - deriving (Show, Read) + deriving (Show, Read, Eq, Ord) data Endianness = LittleEndian | BigEndian - deriving (Show, Read) + deriving (Show, Read, Eq, Ord) -- | A 'Target' consists of: -- @@ -63,4 +63,5 @@ data Target = Target , tgtDllwrap :: Maybe Program , tgtWindres :: Maybe Program } - deriving (Show, Read) + deriving (Show, Read, Eq, Ord) + ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ar.hs ===================================== @@ -17,7 +17,7 @@ data Ar = Ar { arMkArchive :: Program , arSupportsDashL :: Bool , arNeedsRanlib :: Bool } - deriving (Show, Read) + deriving (Show, Read, Eq, Ord) findAr :: ProgOpt -> M Ar findAr progOpt = checking "for 'ar'" $ do ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs ===================================== @@ -19,9 +19,9 @@ import GHC.Toolchain.Prelude import GHC.Toolchain.Utils import GHC.Toolchain.Program -data Cc = Cc { ccProgram :: Program - } - deriving (Show, Read) +newtype Cc = Cc { ccProgram :: Program + } + deriving (Show, Read, Eq, Ord) _ccProgram :: Lens Cc Program _ccProgram = Lens ccProgram (\x o -> o{ccProgram=x}) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs ===================================== @@ -9,9 +9,9 @@ import GHC.Toolchain.Program import GHC.Toolchain.Tools.Cc -data Cpp = Cpp { cppProgram :: Program - } - deriving (Show, Read) +newtype Cpp = Cpp { cppProgram :: Program + } + deriving (Show, Read, Eq, Ord) findCpp :: ProgOpt -> Cc -> M Cpp findCpp progOpt cc ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs ===================================== @@ -8,9 +8,9 @@ module GHC.Toolchain.Tools.Cxx import GHC.Toolchain.Prelude import GHC.Toolchain.Program -data Cxx = Cxx { cxxProgram :: Program - } - deriving (Show, Read) +newtype Cxx = Cxx { cxxProgram :: Program + } + deriving (Show, Read, Eq, Ord) findCxx :: ProgOpt -> M Cxx findCxx progOpt = checking "for C++ compiler" $ do ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -20,7 +20,7 @@ import GHC.Toolchain.Tools.Readelf data CcLink = CcLink { ccLinkProgram :: Program , ccLinkSupportsNoPie :: Bool } - deriving (Show, Read) + deriving (Show, Read, Eq, Ord) findCcLink :: ProgOpt -> Maybe Bool -> ArchOS -> Cc -> Maybe Readelf -> M CcLink findCcLink progOpt ldOverride archOs cc readelf = checking "for C compiler for linking command" $ do ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.hs ===================================== @@ -17,9 +17,9 @@ import GHC.Toolchain.Tools.Link import GHC.Toolchain.Tools.Nm -- | Configuration on how the C compiler can be used to link -data MergeObjs = MergeObjs { mergeObjsProgram :: Program - } - deriving (Show, Read) +newtype MergeObjs = MergeObjs { mergeObjsProgram :: Program + } + deriving (Show, Read, Eq, Ord) findMergeObjs :: ProgOpt -> Cc -> CcLink -> Nm -> M MergeObjs findMergeObjs progOpt cc ccLink nm = checking "for linker for merging objects" $ do ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Nm.hs ===================================== @@ -8,9 +8,9 @@ import Control.Monad import GHC.Toolchain.Prelude import GHC.Toolchain.Program -data Nm = Nm { nmProgram :: Program - } - deriving (Show, Read) +newtype Nm = Nm { nmProgram :: Program + } + deriving (Show, Read, Eq, Ord) findNm :: ProgOpt -> M Nm findNm progOpt = checking "for 'nm'" $ do ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Ranlib.hs ===================================== @@ -8,9 +8,9 @@ module GHC.Toolchain.Tools.Ranlib import GHC.Toolchain.Prelude import GHC.Toolchain.Program -data Ranlib = Ranlib { ranlibProgram :: Program - } - deriving (Show, Read) +newtype Ranlib = Ranlib { ranlibProgram :: Program + } + deriving (Show, Read, Eq, Ord) findRanlib :: ProgOpt -> M Ranlib findRanlib progOpt = checking "for 'ranlib'" $ do ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Readelf.hs ===================================== @@ -8,8 +8,8 @@ import Control.Monad import GHC.Toolchain.Prelude import GHC.Toolchain.Program -data Readelf = Readelf { readelfProgram :: Program - } +newtype Readelf = Readelf { readelfProgram :: Program + } deriving (Show, Read) -- | Readelf is only needed by 'GHC.Toolchain.Tools.Link.checkBfdCopyBug'. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0c7fdc84f685dd884d0133b4290636136606f02 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0c7fdc84f685dd884d0133b4290636136606f02 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 12:15:37 2023 From: gitlab at gitlab.haskell.org (Cheng Shao (@TerrorJack)) Date: Mon, 08 May 2023 08:15:37 -0400 Subject: [Git][ghc/ghc][wip/T22756] rts: Fix data-race in hs_init_ghc Message-ID: <6458e7e9ae403_38ffda42b8ab7c34332e@gitlab.mail> Cheng Shao pushed to branch wip/T22756 at Glasgow Haskell Compiler / GHC Commits: 3e3a6be4 by Ben Gamari at 2023-05-08T12:15:19+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 1 changed file: - rts/RtsStartup.c Changes: ===================================== rts/RtsStartup.c ===================================== @@ -68,7 +68,7 @@ #endif // Count of how many outstanding hs_init()s there have been. -static int hs_init_count = 0; +static StgWord hs_init_count = 0; static bool rts_shutdown = false; #if defined(mingw32_HOST_OS) @@ -242,8 +242,9 @@ hs_init_with_rtsopts(int *argc, char **argv[]) void hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) { - hs_init_count++; - if (hs_init_count > 1) { + // N.B. atomic_inc returns the new value. + StgWord init_count = atomic_inc(&hs_init_count, 1); + if (init_count > 1) { // second and subsequent inits are ignored return; } @@ -452,15 +453,17 @@ hs_exit_(bool wait_foreign) { uint32_t g, i; - if (hs_init_count <= 0) { - errorBelch("warning: too many hs_exit()s"); + // N.B. atomic_dec returns the new value. + StgInt init_count = (StgInt)atomic_dec(&hs_init_count); + if (init_count > 0) { + // ignore until it's the last one return; } - hs_init_count--; - if (hs_init_count > 0) { - // ignore until it's the last one + if (init_count < 0) { + errorBelch("warning: too many hs_exit()s"); return; } + rts_shutdown = true; /* start timing the shutdown */ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e3a6be4023189b2d637beda240e23fa9e856810 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e3a6be4023189b2d637beda240e23fa9e856810 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 12:59:35 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 08:59:35 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] 2 commits: Re-introduce flags in hadrian config Message-ID: <6458f237b4432_38ffda474950883723c8@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: db50d45e by Rodrigo Mesquita at 2023-05-08T13:31:08+01:00 Re-introduce flags in hadrian config - - - - - c8a95b77 by Rodrigo Mesquita at 2023-05-08T13:59:30+01:00 ROMES WIP - - - - - 4 changed files: - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Builder.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs Changes: ===================================== hadrian/bindist/config.mk.in ===================================== @@ -234,16 +234,28 @@ GhcRtsWithLibdw=$(strip $(if $(filter $(TargetArch_CPP),i386 x86_64 s390x), at UseL # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] +GccExtraViaCOpts = @GccExtraViaCOpts@ LdHasFilelist = @LdHasFilelist@ LdSupportsResponseFiles = @LdSupportsResponseFiles@ LdHasBuildId = @LdHasBuildId@ LdHasFilelist = @LdHasFilelist@ LdIsGNULd = @LdIsGNULd@ LdHasNoCompactUnwind = @LdHasNoCompactUnwind@ +ArArgs = @ArArgs@ +ArSupportsAtFile = @ArSupportsAtFile@ +ArSupportsDashL = @ArSupportsDashL@ HaskellHostOs = @HaskellHostOs@ HaskellHostArch = @HaskellHostArch@ +HaskellTargetOs = @HaskellTargetOs@ +HaskellTargetArch = @HaskellTargetArch@ +TargetWordSize = @TargetWordSize@ +TargetWordBigEndian = @TargetWordBigEndian@ +TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ +TargetHasIdentDirective = @TargetHasIdentDirective@ +TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ +TablesNextToCode = @TablesNextToCode@ SettingsCCompilerCommand = @SettingsCCompilerCommand@ SettingsCxxCompilerCommand = @SettingsCxxCompilerCommand@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -39,7 +39,9 @@ python = @PythonCmd@ # Information about builders: #============================ +ar-supports-at-file = @ArSupportsAtFile@ system-ar-supports-at-file = @ArSupportsAtFile_STAGE0@ +ar-supports-dash-l = @ArSupportsDashL@ system-ar-supports-dash-l = @ArSupportsDashL_STAGE0@ cc-llvm-backend = @CcLlvmBackend@ hs-cpp-args = @HaskellCPPArgs@ @@ -47,8 +49,11 @@ hs-cpp-args = @HaskellCPPArgs@ # Build options: #=============== +ghc-unregisterised = @Unregisterised@ +tables-next-to-code = @TablesNextToCode@ use-libffi-for-adjustors = @UseLibffiForAdjustors@ ghc-source-path = @hardtop@ +leading-underscore = @LeadingUnderscore@ # Information about build, host and target systems: #================================================== @@ -136,6 +141,7 @@ ld-has-no-compact-unwind = @LdHasNoCompactUnwind@ ld-has-filelist = @LdHasFilelist@ ld-supports-response-files = @LdSupportsResponseFiles@ ld-is-gnu-ld = @LdIsGNULd@ +ar-args = @ArArgs@ settings-c-compiler-command = @SettingsCCompilerCommand@ settings-cxx-compiler-command = @SettingsCxxCompilerCommand@ ===================================== hadrian/src/Builder.hs ===================================== @@ -43,6 +43,10 @@ import qualified Data.ByteString as BS import qualified GHC.Foreign as GHC import GHC.ResponseFile +import GHC.Toolchain (Target(..)) +import qualified GHC.Toolchain as Toolchain +import GHC.Toolchain.Program + -- | C compiler can be used in two different modes: -- * Compile or preprocess a source file. -- * Extract source dependencies by passing @-MM@ command line argument. @@ -415,18 +419,18 @@ isOptional = \case systemBuilderPath :: Builder -> Action FilePath systemBuilderPath builder = case builder of Alex -> fromKey "alex" - Ar _ (Stage0 {})-> fromKey "system-ar" - Ar _ _ -> fromKey "ar" + Ar _ (Stage0 {})-> fromHostTC "system-ar" (Toolchain.arMkArchive . tgtAr) + Ar _ _ -> fromTargetTC "ar" (Toolchain.arMkArchive . tgtAr) Autoreconf _ -> stripExe =<< fromKey "autoreconf" - Cc _ (Stage0 {}) -> fromKey "system-cc" - Cc _ _ -> fromKey "cc" + Cc _ (Stage0 {}) -> fromHostTC "system-cc" (Toolchain.ccProgram . tgtCCompiler) + Cc _ _ -> fromTargetTC "cc" (Toolchain.ccProgram . tgtCCompiler) -- We can't ask configure for the path to configure! Configure _ -> return "configure" Ghc _ (Stage0 {}) -> fromKey "system-ghc" GhcPkg _ (Stage0 {}) -> fromKey "system-ghc-pkg" Happy -> fromKey "happy" HsCpp -> fromKey "hs-cpp" - Ld _ -> fromKey "ld" + Ld _ -> fromTargetTC "ld" (Toolchain.ccLinkProgram . tgtCCompilerLink) -- ROMES:TODO ld vs cLink -- MergeObjects Stage0 is a special case in case of -- cross-compiling. We're building stage1, e.g. code which will be -- executed on the host and hence we need to use host's merge @@ -435,15 +439,15 @@ systemBuilderPath builder = case builder of -- parameters. E.g. building a cross-compiler on and for x86_64 -- which will target ppc64 means that MergeObjects Stage0 will use -- x86_64 linker and MergeObject _ will use ppc64 linker. - MergeObjects (Stage0 {}) -> fromKey "system-merge-objects" - MergeObjects _ -> fromKey "merge-objects" + MergeObjects (Stage0 {}) -> fromHostTC "system-merge-objects" (maybeProg Toolchain.mergeObjsProgram . tgtMergeObjs) + MergeObjects _ -> fromTargetTC "merge-objects" (maybeProg Toolchain.mergeObjsProgram . tgtMergeObjs) Make _ -> fromKey "make" Makeinfo -> fromKey "makeinfo" - Nm -> fromKey "nm" + Nm -> fromTargetTC "nm" (Toolchain.nmProgram . tgtNm) Objdump -> fromKey "objdump" Patch -> fromKey "patch" Python -> fromKey "python" - Ranlib -> fromKey "ranlib" + Ranlib -> fromTargetTC "ranlib" (maybeProg Toolchain.ranlibProgram . tgtRanlib) Testsuite _ -> fromKey "python" Sphinx _ -> fromKey "sphinx-build" Tar _ -> fromKey "tar" @@ -459,10 +463,23 @@ systemBuilderPath builder = case builder of let unpack = fromMaybe . error $ "Cannot find path to builder " ++ quote key ++ inCfg ++ " Did you skip configure?" path <- unpack <$> lookupValue configFile key + validate key path + + -- Get program from the host's target configuration + fromHostTC keyname key = do + path <- queryHostTargetConfig (prgPath . key) + validate keyname path + + -- Get program from the target's target configuration + fromTargetTC keyname key = do + path <- queryTargetTargetConfig (prgPath . key) + validate keyname path + + validate keyname path = do if null path then do unless (isOptional builder) . error $ "Non optional builder " - ++ quote key ++ " is not specified" ++ inCfg + ++ quote keyname ++ " is not specified" ++ inCfg return "" -- TODO: Use a safe interface. else do -- angerman: I find this lookupInPath rather questionable. @@ -488,6 +505,8 @@ systemBuilderPath builder = case builder of exists <- doesFileExist s if exists then return s else return sNoExt + maybeProg = maybe (Program "" []) + -- | Was the path to a given system 'Builder' specified in configuration files? isSpecified :: Builder -> Action Bool ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -48,14 +48,14 @@ data Target = Target -- C toolchain , tgtCCompiler :: Cc , tgtCxxCompiler :: Cxx - , tgtCPreprocessor :: Cpp + , tgtCPreprocessor :: Cpp -- ROMES:TODO: Is this hs-cpp or cpp? Do I need both? , tgtCCompilerLink :: CcLink -- , tgtLd :: Program -- needed? -- , tgtLdSupportsCompactUnwind :: Bool -- , tgtLdSupportsFilelist :: Bool -- , tgtLdIsGnuLd :: Bool -- needed? , tgtAr :: Ar - , tgtRanlib :: Maybe Ranlib + , tgtRanlib :: Maybe Ranlib -- why is this marked as maybe? , tgtNm :: Nm , tgtMergeObjs :: Maybe MergeObjs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e0c7fdc84f685dd884d0133b4290636136606f02...c8a95b770fa4b1f4eba4ff4c3479f62a1168a4e1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e0c7fdc84f685dd884d0133b4290636136606f02...c8a95b770fa4b1f4eba4ff4c3479f62a1168a4e1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 14:56:21 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Mon, 08 May 2023 10:56:21 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/js-clock_gettime Message-ID: <64590d9547c1_38ffda4fd3625c4252d@gitlab.mail> Josh Meredith pushed new branch wip/js-clock_gettime at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/js-clock_gettime You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 14:59:03 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Mon, 08 May 2023 10:59:03 -0400 Subject: [Git][ghc/ghc][wip/js-clock_gettime] JS: Implement h$clock_gettime in the JavaScript RTS (#23360) Message-ID: <64590e37b2942_38ffda50a2d8704280d6@gitlab.mail> Spam detection software, running on the system "mail.haskell.org", has identified this incoming email as possible spam. The original message has been attached to this so you can view it (if it isn't spam) or label similar future email. If you have any questions, see @@CONTACT_ADDRESS@@ for details. Content preview: Josh Meredith pushed to branch wip/js-clock_gettime at Glasgow Haskell Compiler / GHC Commits: 8e52b799 by Josh Meredith at 2023-05-08T14:58:42+00:00 JS: Implement h$clock_gettime in the JavaScript RTS (#23360) [...] Content analysis details: (6.9 points, 5.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- -0.0 T_RP_MATCHES_RCVD Envelope sender domain matches handover relay domain 1.1 URI_HEX URI: URI hostname has long hexadecimal sequence 5.0 UNWANTED_LANGUAGE_BODY BODY: Message written in an undesired language 0.0 HTML_MESSAGE BODY: HTML included in message 0.8 BAYES_50 BODY: Bayes spam probability is 40 to 60% [score: 0.4278] 0.0 T_DKIM_INVALID DKIM-Signature header exists but is not valid The original message was not completely plain text, and may be unsafe to open with some email clients; in particular, it may contain a virus, or confirm that your address can receive spam. If you wish to view it, it may be safer to save it to a file and open it with an editor. -------------- next part -------------- An embedded message was scrubbed... From: "Josh Meredith (@JoshMeredith)" Subject: [Git][ghc/ghc][wip/js-clock_gettime] JS: Implement h$clock_gettime in the JavaScript RTS (#23360) Date: Mon, 08 May 2023 10:59:03 -0400 Size: 54919 URL: From gitlab at gitlab.haskell.org Mon May 8 15:21:00 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 11:21:00 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/romes/target-has-rts-linker Message-ID: <6459135c57660_38ffda51bb8f404408f8@gitlab.mail> Rodrigo Mesquita pushed new branch wip/romes/target-has-rts-linker at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/romes/target-has-rts-linker You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 15:34:47 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 11:34:47 -0400 Subject: [Git][ghc/ghc][wip/romes/target-has-rts-linker] Move "target has RTS linker" out of settings Message-ID: <645916973ed2e_38ffda520e197c445289@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/target-has-rts-linker at Glasgow Haskell Compiler / GHC Commits: b4b1644a by Rodrigo Mesquita at 2023-05-08T16:34:37+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Closes #23361 - - - - - 9 changed files: - compiler/GHC/Driver/Session.hs - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -222,6 +222,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile +import GHC.Platform.ArchOS import GHC.UniqueSubdir (uniqueSubdir) import GHC.Unit.Types @@ -4727,8 +4728,9 @@ compilerInfo dflags ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), - ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), + ("Have native code generator", showBool $ platformNcgSupported platform), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make at . @@ -4769,6 +4771,23 @@ compilerInfo dflags expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd +-- | Does this target have an RTS linker? +-- Romes: Perhaps not the best place for the function +platformHasRTSLinker :: Platform -> Bool +platformHasRTSLinker p = case platformArchOS p of + -- NO for powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) + ArchPPC -> False -- What about powerpc other than powerpc-ibm-aix*? + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False -- What about s390x other than s390x-ibm-linux? + ArchRISCV64 -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + ArchWasm32 -> False + _ -> True + + + -- | Get target profile targetProfile :: DynFlags -> Profile targetProfile dflags = Profile (targetPlatform dflags) (ways dflags) ===================================== configure.ac ===================================== @@ -330,18 +330,6 @@ if test x"$TablesNextToCode" = xYES; then fi AC_SUBST(TablesNextToCode) -dnl ** Does target have runtime linker support? -dnl -------------------------------------------------------------- -case "$target" in - powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) - TargetHasRTSLinker=NO - ;; - *) - TargetHasRTSLinker=YES - ;; -esac -AC_SUBST(TargetHasRTSLinker) - # Requires FPTOOLS_SET_PLATFORMS_VARS to be run first. FP_FIND_ROOT ===================================== distrib/configure.ac.in ===================================== @@ -20,9 +20,6 @@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ -TargetHasRTSLinker=@TargetHasRTSLinker@ -AC_SUBST(TargetHasRTSLinker) - TargetHasLibm=@TargetHasLibm@ AC_SUBST(TargetHasLibm) ===================================== hadrian/bindist/Makefile ===================================== @@ -116,7 +116,6 @@ lib/settings : config.mk @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ - @echo ',("target has RTS linker", "$(TargetHasRTSLinker)")' >> $@ @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ @echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -253,7 +253,6 @@ TargetWordBigEndian = @TargetWordBigEndian@ TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ TargetHasIdentDirective = @TargetHasIdentDirective@ TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -173,7 +173,6 @@ target-word-big-endian = @TargetWordBigEndian@ target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@ target-has-ident-directive = @TargetHasIdentDirective@ target-has-subsections-via-symbols = @TargetHasSubsectionsViaSymbols@ -target-has-rts-linker = @TargetHasRTSLinker@ target-has-libm = @TargetHasLibm@ target-arm-version = @ARM_ISA@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -79,7 +79,6 @@ data Setting = BuildArch | TargetOsHaskell | TargetArmVersion | TargetWordSize - | TargetHasRtsLinker | BourneShell -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). @@ -181,7 +180,6 @@ setting key = lookupSystemConfig $ case key of TargetArchHaskell -> "target-arch-haskell" TargetOsHaskell -> "target-os-haskell" TargetWordSize -> "target-word-size" - TargetHasRtsLinker -> "target-has-rts-linker" BourneShell -> "bourne-shell" bootIsStage0 :: Stage -> Stage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -451,7 +451,6 @@ generateSettings = do , ("target has GNU nonexec stack", expr $ lookupSystemConfig "target-has-gnu-nonexec-stack") , ("target has .ident directive", expr $ lookupSystemConfig "target-has-ident-directive") , ("target has subsections via symbols", expr $ lookupSystemConfig "target-has-subsections-via-symbols") - , ("target has RTS linker", expr $ lookupSystemConfig "target-has-rts-linker") , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) , ("LLVM target", getSetting LlvmTarget) ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -126,7 +126,10 @@ inTreeCompilerArgs stg = do libdir <- System.FilePath.normalise . (top -/-) <$> stageLibPath stg - rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker + -- romes: Dear reviewer, I'm not sure if it's OK to do this here, but we no + -- longer "know" the information, we can only query either ghc --info, or + -- the test settings (which indirectly queried the ghc --info) + rtsLinker <- getBooleanSetting TestGhcWithRtsLinker return TestCompilerArgs{..} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4b1644ab5081aea5e170740c8ba7f73a71620be -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4b1644ab5081aea5e170740c8ba7f73a71620be You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 15:55:49 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 11:55:49 -0400 Subject: [Git][ghc/ghc][wip/romes/target-has-rts-linker] Move "target has RTS linker" out of settings Message-ID: <64591b858e9ed_38ffda538849d04546e3@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/target-has-rts-linker at Glasgow Haskell Compiler / GHC Commits: dd67008c by Rodrigo Mesquita at 2023-05-08T16:55:36+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Closes #23361 - - - - - 9 changed files: - compiler/GHC/Driver/Session.hs - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -222,6 +222,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile +import GHC.Platform.ArchOS import GHC.UniqueSubdir (uniqueSubdir) import GHC.Unit.Types @@ -4727,8 +4728,9 @@ compilerInfo dflags ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), - ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), + ("Have native code generator", showBool $ platformNcgSupported platform), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make at . @@ -4769,6 +4771,23 @@ compilerInfo dflags expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd +-- | Does this target have an RTS linker? +-- Romes: Perhaps not the best place for the function +platformHasRTSLinker :: Platform -> Bool +-- NO for powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) +platformHasRTSLinker p = case archOS_arch (platformArchOS p) of + ArchPPC -> False -- What about powerpc other than powerpc-ibm-aix*? + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False -- What about s390x other than s390x-ibm-linux? + ArchRISCV64 -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + ArchWasm32 -> False + _ -> True + + + -- | Get target profile targetProfile :: DynFlags -> Profile targetProfile dflags = Profile (targetPlatform dflags) (ways dflags) ===================================== configure.ac ===================================== @@ -330,18 +330,6 @@ if test x"$TablesNextToCode" = xYES; then fi AC_SUBST(TablesNextToCode) -dnl ** Does target have runtime linker support? -dnl -------------------------------------------------------------- -case "$target" in - powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) - TargetHasRTSLinker=NO - ;; - *) - TargetHasRTSLinker=YES - ;; -esac -AC_SUBST(TargetHasRTSLinker) - # Requires FPTOOLS_SET_PLATFORMS_VARS to be run first. FP_FIND_ROOT ===================================== distrib/configure.ac.in ===================================== @@ -20,9 +20,6 @@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ -TargetHasRTSLinker=@TargetHasRTSLinker@ -AC_SUBST(TargetHasRTSLinker) - TargetHasLibm=@TargetHasLibm@ AC_SUBST(TargetHasLibm) ===================================== hadrian/bindist/Makefile ===================================== @@ -116,7 +116,6 @@ lib/settings : config.mk @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ - @echo ',("target has RTS linker", "$(TargetHasRTSLinker)")' >> $@ @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ @echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -253,7 +253,6 @@ TargetWordBigEndian = @TargetWordBigEndian@ TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ TargetHasIdentDirective = @TargetHasIdentDirective@ TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -173,7 +173,6 @@ target-word-big-endian = @TargetWordBigEndian@ target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@ target-has-ident-directive = @TargetHasIdentDirective@ target-has-subsections-via-symbols = @TargetHasSubsectionsViaSymbols@ -target-has-rts-linker = @TargetHasRTSLinker@ target-has-libm = @TargetHasLibm@ target-arm-version = @ARM_ISA@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -79,7 +79,6 @@ data Setting = BuildArch | TargetOsHaskell | TargetArmVersion | TargetWordSize - | TargetHasRtsLinker | BourneShell -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). @@ -181,7 +180,6 @@ setting key = lookupSystemConfig $ case key of TargetArchHaskell -> "target-arch-haskell" TargetOsHaskell -> "target-os-haskell" TargetWordSize -> "target-word-size" - TargetHasRtsLinker -> "target-has-rts-linker" BourneShell -> "bourne-shell" bootIsStage0 :: Stage -> Stage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -451,7 +451,6 @@ generateSettings = do , ("target has GNU nonexec stack", expr $ lookupSystemConfig "target-has-gnu-nonexec-stack") , ("target has .ident directive", expr $ lookupSystemConfig "target-has-ident-directive") , ("target has subsections via symbols", expr $ lookupSystemConfig "target-has-subsections-via-symbols") - , ("target has RTS linker", expr $ lookupSystemConfig "target-has-rts-linker") , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) , ("LLVM target", getSetting LlvmTarget) ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -126,7 +126,10 @@ inTreeCompilerArgs stg = do libdir <- System.FilePath.normalise . (top -/-) <$> stageLibPath stg - rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker + -- romes: Dear reviewer, I'm not sure if it's OK to do this here, but we no + -- longer "know" the information, we can only query either ghc --info, or + -- the test settings (which indirectly queried the ghc --info) + rtsLinker <- getBooleanSetting TestGhcWithRtsLinker return TestCompilerArgs{..} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dd67008c610bfc57b8796c8fda9bda5408f83e7b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dd67008c610bfc57b8796c8fda9bda5408f83e7b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 16:21:37 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 12:21:37 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] 151 commits: Move "target has RTS linker" out of settings Message-ID: <64592191e1638_38ffda5482991c4633e6@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: dd67008c by Rodrigo Mesquita at 2023-05-08T16:55:36+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Closes #23361 - - - - - 142775c8 by Adam Gundry at 2023-05-08T17:15:38+01:00 Allow WARNING pragmas to be controlled with custom categories Closes #17209. This implements GHC Proposal 541, allowing a WARNING pragma to be annotated with a category like so: {-# WARNING in "x-partial" head "This function is undefined on empty lists." #-} The user can then enable, disable and set the severity of such warnings using command-line flags `-Wx-partial`, `-Werror=x-partial` and so on. There is a new warning group `-Wextended-warnings` containing all these warnings. Warnings without a category are treated as if the category was `deprecations`, and are (still) controlled by the flags `-Wdeprecations` and `-Wwarnings-deprecations`. Updates Haddock submodule. - - - - - 7bf71fe0 by Adam Gundry at 2023-05-08T17:15:38+01:00 Move mention of warning groups change to 9.8.1 release notes - - - - - cb496562 by Ben Gamari at 2023-05-08T17:15:39+01:00 nativeGen/AArch64: Fix bitmask immediate predicate Previously the predicate for determining whether a logical instruction operand could be encoded as a bitmask immediate was far too conservative. This meant that, e.g., pointer untagged required five instructions whereas it should only require one. Fixes #23030. - - - - - fab737d9 by Joachim Breitner at 2023-05-08T17:15:39+01:00 User's guide: Improve docs for -Wall previously it would list the warnings _not_ enabled by -Wall. That’s unnecessary round-about and was out of date. So let's just name the relevant warnings (based on `compiler/GHC/Driver/Flags.hs`). - - - - - b1c8aeb3 by Ben Gamari at 2023-05-08T17:15:39+01:00 codeGen/tsan: Disable instrumentation of unaligned stores There is some disagreement regarding the prototype of `__tsan_unaligned_write` (specifically whether it takes just the written address, or the address and the value as an argument). Moreover, I have observed crashes which appear to be due to it. Disable instrumentation of unaligned stores as a temporary mitigation. Fixes #23096. - - - - - 45a7d267 by Li-yao Xia at 2023-05-08T17:15:39+01:00 base: Document GHC versions associated with past base versions in the changelog - - - - - a6dc746c by Teo Camarasu at 2023-05-08T17:15:39+01:00 Add regression test for #17574 This test currently fails in the nonmoving way - - - - - 634562c2 by Teo Camarasu at 2023-05-08T17:15:39+01:00 fix: account for large and compact object stats with nonmoving gc Make sure that we keep track of the size of large and compact objects that have been moved onto the nonmoving heap. We keep track of their size and add it to the amount of live bytes in nonmoving segments to get the total size of the live nonmoving heap. Resolves #17574 - - - - - cd4e2bac by David Feuer at 2023-05-08T17:15:39+01:00 Modify ThreadId documentation and comments For a long time, `GHC.Conc.Sync` has said ```haskell -- ToDo: data ThreadId = ThreadId (Weak ThreadId#) -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. ``` We are now actually capable of using `Weak# ThreadId#`, but the world has moved on. To support the `Show` and `Ord` instances, we'd need to store the thread ID number in the `ThreadId`. And it seems very difficult to continue to support `threadStatus` in that regime, since it needs to be able to explain how threads died. In addition, garbage collection of weak references can be quite expensive, and it would be hard to evaluate the cost over he whole ecosystem. As discussed in [this CLC issue](https://github.com/haskell/core-libraries-committee/issues/125), it doesn't seem very likely that we'll actually switch to weak references here. - - - - - bbcef12d by Ben Gamari at 2023-05-08T17:15:39+01:00 rts: Fix barriers of IND and IND_STATIC Previously IND and IND_STATIC lacked the acquire barriers enjoyed by BLACKHOLE. As noted in the (now updated) Note [Heap memory barriers], this barrier is critical to ensure that the indirectee is visible to the entering core. Fixes #22872. - - - - - 1b36f3f5 by Bodigrim at 2023-05-08T17:15:39+01:00 Improve documentation of atomicModifyMutVar2# - - - - - 1a534de5 by Cheng Shao at 2023-05-08T17:15:39+01:00 rts: use performBlockingMajorGC in hs_perform_gc and fix ffi023 This patch does a few things: - Add the missing RtsSymbols.c entry of performBlockingMajorGC - Make hs_perform_gc call performBlockingMajorGC, which restores previous behavior - Use hs_perform_gc in ffi023 - Remove rts_clearMemory() call in ffi023, it now works again in some test ways previously marked as broken. Fixes #23089 - - - - - a641341e by Cheng Shao at 2023-05-08T17:15:39+01:00 testsuite: add the rts_clearMemory test case This patch adds a standalone test case for rts_clearMemory that mimics how it's typically used by wasm backend users and ensures this RTS API isn't broken by future RTS refactorings. Fixes #23901. - - - - - 08283d15 by Bodigrim at 2023-05-08T17:15:39+01:00 Improve documentation for resizing of byte arrays - - - - - b508c084 by Ben Gamari at 2023-05-08T17:15:39+01:00 rts: Don't rely on EXTERN_INLINE for slop-zeroing logic Previously we relied on calling EXTERN_INLINE functions defined in ClosureMacros.h from Cmm to zero slop. However, as far as I can tell, this is no longer safe to do in C99 as EXTERN_INLINE definitions may be emitted in each compilation unit. Fix this by explicitly declaring a new set of non-inline functions in ZeroSlop.c which can be called from Cmm and marking the ClosureMacros.h definitions as INLINE_HEADER. In the future we should try to eliminate EXTERN_INLINE. - - - - - b6ec46f3 by Ben Gamari at 2023-05-08T17:15:39+01:00 rts: Fix capability-count check in zeroSlop Previously `zeroSlop` examined `RtsFlags` to determine whether the program was single-threaded. This is wrong; a program may be started with `+RTS -N1` yet the process may later increase the capability count with `setNumCapabilities`. This lead to quite subtle and rare crashes. Fixes #23088. - - - - - 47288afe by Ryan Scott at 2023-05-08T17:15:39+01:00 Add Eq/Ord instances for SSymbol, SChar, and SNat This implements [CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148). - - - - - a1c88104 by David Feuer at 2023-05-08T17:15:39+01:00 Update and expand atomic modification Haddocks * The documentation for `atomicModifyIORef` and `atomicModifyIORef'` were incomplete, and the documentation for `atomicModifyIORef` was out of date. Update and expand. * Remove a useless lazy pattern match in the definition of `atomicModifyIORef`. The pair it claims to match lazily was already forced by `atomicModifyIORef2`. - - - - - 41f9a05a by David Feuer at 2023-05-08T17:15:39+01:00 Document the constructor name for lists Derived `Data` instances use raw infix constructor names when applicable. The `Data.Data [a]` instance, if derived, would have a constructor name of `":"`. However, it actually uses constructor name `"(:)"`. Document this peculiarity. See https://github.com/haskell/core-libraries-committee/issues/147 - - - - - a403d629 by Simon Peyton Jones at 2023-05-08T17:15:39+01:00 Make exprIsConApp_maybe a bit cleverer Addresses #23159. See Note Note [Exploit occ-info in exprIsConApp_maybe] in GHC.Core.SimpleOpt. Compile times go down very slightly, but always go down, never up. Good! Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -1.8% T15703(normal) -1.2% GOOD geo. mean -0.1% minimum -1.8% maximum +0.0% Metric Decrease: CoOpt_Singletons T15703 - - - - - 22cf433c by Ryan Scott at 2023-05-08T17:15:39+01:00 Add COMPLETE pragmas to TypeRep, SSymbol, SChar, and SNat This implements [CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149). - - - - - 8f201d82 by sheaf at 2023-05-08T17:15:39+01:00 Handle records in the renamer This patch moves the field-based logic for disambiguating record updates to the renamer. The type-directed logic, scheduled for removal, remains in the typechecker. To do this properly (and fix the myriad of bugs surrounding the treatment of duplicate record fields), we took the following main steps: 1. Create GREInfo, a renamer-level equivalent to TyThing which stores information pertinent to the renamer. This allows us to uniformly treat imported and local Names in the renamer, as described in Note [GREInfo]. 2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which distinguished between normal names and field names, we now store simple Names in GlobalRdrElt, along with the new GREInfo information which allows us to recover the FieldLabel for record fields. 3. Add namespacing for record fields, within the OccNames themselves. This allows us to remove the mangling of duplicate field selectors. This change ensures we don't print mangled names to the user in error messages, and allows us to handle duplicate record fields in Template Haskell. 4. Move record disambiguation to the renamer, and operate on the level of data constructors instead, to handle #21443. The error message text for ambiguous record updates has also been changed to reflect that type-directed disambiguation is on the way out. (3) means that OccEnv is now a bit more complex: we first key on the textual name, which gives an inner map keyed on NameSpace: OccEnv a ~ FastStringEnv (UniqFM NameSpace a) Note that this change, along with (2), both increase the memory residency of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to regress somewhat in compile-time allocation. Even though (3) simplified a lot of code (in particular the treatment of field selectors within Template Haskell and in error messages), it came with one important wrinkle: in the situation of -- M.hs-boot module M where { data A; foo :: A -> Int } -- M.hs module M where { data A = MkA { foo :: Int } } we have that M.hs-boot exports a variable foo, which is supposed to match with the record field foo that M exports. To solve this issue, we add a new impedance-matching binding to M foo{var} = foo{fld} This mimics the logic that existed already for impedance-binding DFunIds, but getting it right was a bit tricky. See Note [Record field impedance matching] in GHC.Tc.Module. We also needed to be careful to avoid introducing space leaks in GHCi. So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in ModIface. This means stubbing out all the GREInfo fields, with the function forceGlobalRdrEnv. When we read it back in, we rehydrate with rehydrateGlobalRdrEnv. This robustly avoids any space leaks caused by retaining old type environments. Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063 Updates haddock submodule ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiLayerModulesDefsGhci MultiLayerModulesNoCode T13701 T14697 hard_hole_fits ------------------------- - - - - - 567c7a21 by sheaf at 2023-05-08T17:15:39+01:00 Avoid repeatedly shadowing in shadowNames This commit refactors GHC.Type.Name.Reader.shadowNames to first accumulate all the shadowing arising from the introduction of a new set of GREs, and then applies all the shadowing to the old GlobalRdrEnv in one go. - - - - - 116aa21f by sheaf at 2023-05-08T17:15:39+01:00 igre_prompt_env: discard "only-qualified" names We were unnecessarily carrying around names only available qualified in igre_prompt_env, violating the icReaderEnv invariant. We now get rid of these, as they aren't needed for the shadowing computation that igre_prompt_env exists for. Fixes #23177 ------------------------- Metric Decrease: T14052 T14052Type ------------------------- - - - - - ed70b189 by Matthew Pickering at 2023-05-08T17:15:39+01:00 hadrian: Fix path to HpcParser.y The source for this project has been moved into a src/ folder so we also need to update this path. Fixes #23187 - - - - - 427efe30 by doyougnu at 2023-05-08T17:15:39+01:00 js: split JMacro into JS eDSL and JS syntax This commit: Splits JExpr and JStat into two nearly identical DSLs: - GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a value cannot be unsaturated, or, a value of this DSL is a witness that a value of GHC.JS.Unsat has been saturated - GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation. Then all binary and outputable instances are changed to use GHC.JS.Syntax. This moves us closer to closing out #22736 and #22352. See #22736 for roadmap. ------------------------- Metric Increase: CoOpt_Read LargeRecord ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T10858 T11195 T11374 T11822 T12227 T12707 T13035 T13253 T13253-spj T13379 T14683 T15164 T15703 T16577 T17096 T17516 T17836 T18140 T18282 T18304 T18478 T18698a T18698b T18923 T1969 T19695 T20049 T21839c T3064 T4801 T5321FD T5321Fun T5631 T5642 T783 T9198 T9233 T9630 TcPlugin_RewritePerf WWRec ------------------------- - - - - - 4021abd1 by Sylvain Henry at 2023-05-08T17:15:40+01:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. Also used the opportunity to reenable 64-bit Word/Int tests - - - - - 39e2ba55 by Ben Gamari at 2023-05-08T17:15:40+01:00 testsuite: Fix racing prints in T21465 As noted in #23155, we previously failed to add flushes necessary to ensure predictable output. Fixes #23155. - - - - - e647cdaa by Matthew Pickering at 2023-05-08T17:15:40+01:00 Revert "ghc-heap: remove wrong Addr# coercion (#23181)" This reverts commit f4f1f14f8009c3c120b8b963ec130cbbc774ec02. This fails to build with GHC-9.2 as a boot compiler. See #23195 for tracking this issue. - - - - - 68c6b85a by Bodigrim at 2023-05-08T17:15:40+01:00 Add {-# WARNING #-} to Data.List.{head,tail} - - - - - 6a051a86 by Bodigrim at 2023-05-08T17:15:40+01:00 Fixes to accomodate Data.List.{head,tail} with {-# WARNING #-} - - - - - 7d0b07b5 by Bodigrim at 2023-05-08T17:15:40+01:00 Bump submodules - - - - - 15b6843a by Bodigrim at 2023-05-08T17:15:40+01:00 Fix tests - - - - - 17e080ab by sheaf at 2023-05-08T17:15:40+01:00 Proxies for head and tail: review suggestions - - - - - 5617981e by sheaf at 2023-05-08T17:15:40+01:00 docs: move RecordUpd changelog entry to 9.8 This was accidentally included in the 9.6 changelog instead of the 9.6 changelog. - - - - - b7cb8226 by sheaf at 2023-05-08T17:15:40+01:00 Add LANGUAGE GADTs to GHC.Rename.Env We need to enable this extension for the file to compile with ghc 9.2, as we are pattern matching on a GADT and this required the GADT extension to be enabled until 9.4. - - - - - 67a13bb0 by Cheng Shao at 2023-05-08T17:15:40+01:00 ci: make lint-ci-config job fast again We don't pin our nixpkgs revision and tracks the default nixpkgs-unstable channel anyway. Instead of using haskell.packages.ghc924, we should be using haskell.packages.ghc92 to maximize the binary cache hit rate and make lint-ci-config job fast again. Also bumps the nix docker image to the latest revision. - - - - - 9591669c by Cheng Shao at 2023-05-08T17:15:40+01:00 ci: ensure that all non-i386 pipelines do parallel xz compression We can safely enable parallel xz compression for non-i386 pipelines. However, previously we didn't export XZ_OPT, so the xz process won't see it if XZ_OPT hasn't already been set in the current job. - - - - - 60a6a47e by Cheng Shao at 2023-05-08T17:15:40+01:00 ci: unset CROSS_EMULATOR for js job - - - - - 7f0d43d9 by Cheng Shao at 2023-05-08T17:15:40+01:00 ci: fix lint-testsuite job The list_broken make target will transitively depend on the calibrate.out target, which used STAGE1_GHC instead of TEST_HC. It really should be TEST_HC since that's what get passed in the gitlab CI config. - - - - - c0e71664 by Cheng Shao at 2023-05-08T17:15:40+01:00 ci: use alpine3_17-wasm image for wasm jobs Bump the ci-images dependency and use the new alpine3_17-wasm docker image for wasm jobs. - - - - - bdc97430 by Ben Gamari at 2023-05-08T17:15:40+01:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - 30c75532 by Ben Gamari at 2023-05-08T17:15:40+01:00 testsuite/driver: Normalize away differences in ghc executable name - - - - - 913acf78 by Ben Gamari at 2023-05-08T17:15:40+01:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - d97b871b by Cheng Shao at 2023-05-08T17:15:40+01:00 testsuite: don't add optllvm way for wasm32 - - - - - 279a55e8 by Cheng Shao at 2023-05-08T17:15:40+01:00 testsuite: normalize the .wasm extension - - - - - 1da3dddc by Cheng Shao at 2023-05-08T17:15:40+01:00 testsuite: strip the cross ghc prefix in output and error message - - - - - d02150e3 by Cheng Shao at 2023-05-08T17:15:40+01:00 testsuite: handle target executable extension - - - - - 06260a02 by Cheng Shao at 2023-05-08T17:15:40+01:00 testsuite: mypy typing error fixes This patch fixes some mypy typing errors which weren't caught in previous linting jobs. - - - - - 1c8f24ca by Cheng Shao at 2023-05-08T17:15:40+01:00 testsuite: use context variable instead of thread-local variable This patch changes a thread-local variable to context variable instead, which works as intended when the testsuite transitions to use asyncio & coroutines instead of multi-threading to concurrently run test cases. Note that this also raises the minimum Python version to 3.7. - - - - - eceb22e7 by Cheng Shao at 2023-05-08T17:15:40+01:00 testsuite: asyncify the testsuite driver This patch refactors the testsuite driver, gets rid of multi-threading logic for running test cases concurrently, and uses asyncio & coroutines instead. This is not yak shaving for its own sake; the previous multi-threading logic is prone to livelock/deadlock conditions for some reason, even if the total number of threads is bounded to a thread pool's capacity. The asyncify change is an internal implementation detail of the testsuite driver and does not impact most GHC maintainers out there. The patch does not touch the .T files, test cases can be added/modified the exact same way as before. - - - - - ba06e222 by Matthew Pickering at 2023-05-08T17:15:40+01:00 Add test for T23184 There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj at microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 A bunch of changes related to eta reduction This is a large collection of changes all relating to eta reduction, originally triggered by #18993, but there followed a long saga. Specifics: ...lots of lines omitted... Other incidental changes * Fix a fairly long-standing outright bug in the ApplyToVal case of GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the tail of 'dmds' in the recursive call, which meant the demands were All Wrong. I have no idea why this has not caused problems before now. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes. - - - - - 2de4e679 by mangoiv at 2023-05-08T17:15:40+01:00 [feat] make ($) representation polymorphic - this change was approved by the CLC in [1] following a CLC proposal [2] - make ($) representation polymorphic (adjust the type signature) - change ($) implementation to allow additional polymorphism - adjust the haddock of ($) to reflect these changes - add additional documentation to document these changes - add changelog entry - adjust tests (move now succeeding tests and adjust stdout of some tests) [1] https://github.com/haskell/core-libraries-committee/issues/132#issuecomment-1487456854 [2] https://github.com/haskell/core-libraries-committee/issues/132 - - - - - 8eff2227 by Artem Pelenitsyn at 2023-05-08T17:15:40+01:00 User Guide: update copyright year: 2020->2023 - - - - - d968392e by doyougnu at 2023-05-08T17:15:40+01:00 driver: Unit State Data.Map -> GHC.Unique.UniqMap In pursuit of #22426. The driver and unit state are major contributors. This commit also bumps the haddock submodule to reflect the API changes in UniqMap. ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp T10421 T10547 T12150 T12234 T12425 T13035 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T5837 T6048 T9198 ------------------------- - - - - - 87bb7ef5 by Torsten Schmits at 2023-05-08T17:15:40+01:00 Add structured error messages for GHC.Tc.TyCl Tracking ticket: #20117 MR: !10183 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - ebe616e5 by doyougnu at 2023-05-08T17:15:40+01:00 JS: Linker: use saturated JExpr Follow on to MR!10142 in pursuit of #22736 - - - - - 9d19f237 by sheaf at 2023-05-08T17:15:40+01:00 Improve haddocks of template-haskell Con datatype This adds a bit more information, in particular about the lists of constructors in the GadtC and RecGadtC cases. - - - - - 812c316f by sheaf at 2023-05-08T17:15:40+01:00 TH: revert changes to GadtC & RecGadtC Commit 3f374399 included a breaking-change to the template-haskell library when it made the GadtC and RecGadtC constructors take non-empty lists of names. As this has the potential to break many users' packages, we decided to revert these changes for now. - - - - - 8f5f4c36 by Bodigrim at 2023-05-08T17:15:40+01:00 Rework documentation for data Char - - - - - 8dffda1b by Bodigrim at 2023-05-08T17:15:40+01:00 cmm: implement parsing of MO_AtomicRMW from hand-written CMM files Fixes #23206 - - - - - 30a99449 by Sylvain Henry at 2023-05-08T17:15:41+01:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. - - - - - 3121b78f by Matthew Pickering at 2023-05-08T17:15:41+01:00 hadrian: Update bootstrap plans for 9.2.6, 9.2.7, 9.4.4, 9.4.5, 9.6.1 Also fixes the ./generate_bootstrap_plans script which was recently broken We can hopefully drop the 9.2 plans soon but they still work so kept them around for now. - - - - - 6e4cd95a by Matthew Pickering at 2023-05-08T17:15:41+01:00 ci: Add job to test 9.6 bootstrapping - - - - - 515cc9c3 by Krzysztof Gogolewski at 2023-05-08T17:15:41+01:00 hadrian: Improve option parsing Several options in Hadrian had their argument marked as optional (`OptArg`), but if the argument wasn't there they were just giving an error. It's more idiomatic to mark the argument as required instead; the code uses less Maybes, the parser can enforce that the argument is present, --help gives better output. - - - - - 84db1c60 by Sylvain Henry at 2023-05-08T17:15:41+01:00 JS: fix issues with FD api support - Add missing implementations for fcntl_read/write/lock - Fix fdGetMode These were found while implementing TH in !9779. These functions must be used somehow by the external interpreter code. - - - - - 17bfeb66 by Haskell-mouse at 2023-05-08T17:15:41+01:00 Convert diagnostics in GHC.Rename.HsType to proper TcRnMessage I've turned all occurrences of TcRnUnknownMessage in GHC.Rename.HsType module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnDataKindsError TcRnUnusedQuantifiedTypeVar TcRnIllegalKindSignature TcRnUnexpectedPatSigType TcRnSectionPrecedenceError TcRnPrecedenceParsingError TcRnIllegalKind TcRnNegativeNumTypeLiteral TcRnUnexpectedKindVar TcRnBindMultipleVariables TcRnBindVarAlreadyInScope - - - - - 9f0017de by Krzysztof Gogolewski at 2023-05-08T17:15:41+01:00 Fixes around unsafeCoerce# 1. `unsafeCoerce#` was documented in `GHC.Prim`. But since the overhaul in 74ad75e87317, `unsafeCoerce#` is no longer defined there. I've combined the documentation in `GHC.Prim` with the `Unsafe.Coerce` module. 2. The documentation of `unsafeCoerce#` stated that you should not cast a function to an algebraic type, even if you later cast it back before applying it. But ghci was doing that type of cast, as can be seen with 'ghci -ddump-ds' and typing 'x = not'. I've changed it to use Any following the documentation. - - - - - 5e571c37 by Matthew Craven at 2023-05-08T17:15:41+01:00 Add a few more memcpy-ish primops * copyMutableByteArrayNonOverlapping# * copyAddrToAddr# * copyAddrToAddrNonOverlapping# * setAddrRange# The implementations of copyBytes, moveBytes, and fillBytes in base:Foreign.Marshal.Utils now use these new primops, which can cause us to work a bit harder generating code for them, resulting in the metric increase in T21839c observed by CI on some architectures. But in exchange, we get better code! Metric Increase: T21839c - - - - - 75f22535 by Matthew Craven at 2023-05-08T17:15:41+01:00 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. - - - - - 68410f98 by sheaf at 2023-05-08T17:15:41+01:00 Relax assertion in varToRecFieldOcc When using Template Haskell, it is possible to re-parent a field OccName belonging to one data constructor to another data constructor. The lsp-types package did this in order to "extend" a data constructor with additional fields. This ran into an assertion in 'varToRecFieldOcc'. This assertion can simply be relaxed, as the resulting splices are perfectly sound. Fixes #23220 - - - - - 07e8254f by Sylvain Henry at 2023-05-08T17:15:41+01:00 GHCi.RemoteTypes: fix doc and avoid unsafeCoerce (#23201) - - - - - 4842d530 by Ryan Scott at 2023-05-08T17:15:41+01:00 Make INLINE pragmas for pattern synonyms work with TH Previously, the code for converting `INLINE <name>` pragmas from TH splices used `vNameN`, which assumed that `<name>` must live in the variable namespace. Pattern synonyms, on the other hand, live in the constructor namespace. I've fixed the issue by switching to `vcNameN` instead, which works for both the variable and constructor namespaces. Fixes #23203. - - - - - 0959474d by Krzysztof Gogolewski at 2023-05-08T17:15:41+01:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). - - - - - 301b2568 by sheaf at 2023-05-08T17:15:41+01:00 Add testcase for #23192 This issue around solving of constraints arising from superclass expansion using other constraints also borned from superclass expansion was the topic of commit aed1974e. That commit made sure we don't emit a "redundant constraint" warning in a situation in which removing the constraint would cause errors. Fixes #23192 - - - - - 70f1554c by Ben Gamari at 2023-05-08T17:15:41+01:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 - - - - - 9d9a88b0 by Brandon Chinn at 2023-05-08T17:15:41+01:00 Fix reverse flag for -Wunsupported-llvm-version - - - - - e6d5a420 by Pierre Le Marre at 2023-05-08T17:15:41+01:00 Add release note for GHC.Unicode refactor in base-4.18. Also merge CLC proposal 130 in base-4.19 with CLC proposal 59 in base-4.18 and add proper release date. - - - - - 38c39b1a by Alex Dixon at 2023-05-08T17:15:41+01:00 Improve documentation for ($) (#22963) - - - - - 5b8247dc by Alex Dixon at 2023-05-08T17:15:41+01:00 Remove trailing whitespace from ($) commentary - - - - - 7523dc5b by Sebastian Graf at 2023-05-08T17:15:41+01:00 Adjust wording wrt representation polymorphism of ($) - - - - - 64c010a3 by Torsten Schmits at 2023-05-08T17:15:41+01:00 Add structured error messages for GHC.Tc.TyCl.Utils Tracking ticket: #20117 MR: !10251 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 92a02dd8 by sheaf at 2023-05-08T17:15:41+01:00 Renamer: don't call addUsedGRE on an exact Name When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc, we could end up calling addUsedGRE on an exact Name, which would then lead to a panic in the bestImport function: it would be incapable of processing a GRE which is not local but also not brought into scope by any imports (as it is referred to by its unique instead). Fixes #23240 - - - - - b771e833 by Krzysztof Gogolewski at 2023-05-08T17:15:41+01:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - d9627926 by Krzysztof Gogolewski at 2023-05-08T17:15:41+01:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 002a194a by Cheng Shao at 2023-05-08T17:15:41+01:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 8b68fc0a by Cheng Shao at 2023-05-08T17:15:41+01:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - 4b2673c1 by Bodigrim at 2023-05-08T17:15:41+01:00 Set base 'maintainer' field to CLC - - - - - 48731e24 by Simon Peyton Jones at 2023-05-08T17:15:41+01:00 Clarify a couple of Notes about 'nospec' - - - - - e4f13a4d by Oleg Grenrus at 2023-05-08T17:15:42+01:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 07d65932 by Rodrigo Mesquita at 2023-05-08T17:15:42+01:00 Add regression test for #23229 - - - - - 47f507c5 by Sylvain Henry at 2023-05-08T17:15:42+01:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - bb81ec3f by Sylvain Henry at 2023-05-08T17:15:42+01:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - f34e1cfa by Sylvain Henry at 2023-05-08T17:15:42+01:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8875d6fa by Sylvain Henry at 2023-05-08T17:15:42+01:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 5e9eccd8 by Josh Meredith at 2023-05-08T17:15:42+01:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - 5a7b8f8b by Adam Sandberg Ericsson at 2023-05-08T17:15:42+01:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - 22672235 by Matthew Pickering at 2023-05-08T17:15:42+01:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - 86fc0301 by Simon Peyton Jones at 2023-05-08T17:15:42+01:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - e0c4cdc7 by Simon Peyton Jones at 2023-05-08T17:15:42+01:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 314800a7 by Simon Peyton Jones at 2023-05-08T17:15:42+01:00 Add some documentation about redundant constraints - - - - - c11d35bc by Simon Peyton Jones at 2023-05-08T17:15:42+01:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - ff8d72e5 by Simon Peyton Jones at 2023-05-08T17:15:42+01:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 209fd4a9 by Matthew Pickering at 2023-05-08T17:15:42+01:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - f5acf0b1 by Krzysztof Gogolewski at 2023-05-08T17:15:42+01:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - 3c06b21c by sheaf at 2023-05-08T17:15:42+01:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 359cecaf by Simon Peyton Jones at 2023-05-08T17:15:42+01:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - f3a0bdce by Oleg Grenrus at 2023-05-08T17:15:42+01:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 241a6687 by Matthew Pickering at 2023-05-08T17:15:42+01:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 33de9a76 by Simon Peyton Jones at 2023-05-08T17:15:42+01:00 Add regression test for #23199 - - - - - 885b084c by Ryan Scott at 2023-05-08T17:15:42+01:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 4c8d5b51 by Krzysztof Gogolewski at 2023-05-08T17:15:42+01:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5745479f by Matthew Pickering at 2023-05-08T17:15:42+01:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - 7ede948a by sheaf at 2023-05-08T17:15:43+01:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - 20d9b734 by Sylvain Henry at 2023-05-08T17:15:43+01:00 JS: fix thread-related primops - - - - - 0196f4da by Bryan Richter at 2023-05-08T17:15:43+01:00 CI: Disable abi-test-nightly See #23269 - - - - - da6a1706 by Sylvain Henry at 2023-05-08T17:15:43+01:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - 800ddade by Matthew Pickering at 2023-05-08T17:15:43+01:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 8ea74107 by tocic at 2023-05-08T17:15:43+01:00 Fix doc typo in GHC.Read.readList - - - - - a3c11082 by sheaf at 2023-05-08T17:15:43+01:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - c24b4bbd by Ben Gamari at 2023-05-08T17:15:43+01:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - b3eef6b4 by Ben Gamari at 2023-05-08T17:15:43+01:00 testsuite: Add test for #23071 - - - - - cbe8b444 by tocic at 2023-05-08T17:15:43+01:00 Fix doc typos in libraries/base/GHC - - - - - 1fa73d78 by Sylvain Henry at 2023-05-08T17:15:43+01:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - af39d132 by Krzysztof Gogolewski at 2023-05-08T17:15:43+01:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - 7afd4bb1 by amesgen at 2023-05-08T17:15:43+01:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - aae76738 by PHO at 2023-05-08T17:15:43+01:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 8866a60e by tocic at 2023-05-08T17:15:43+01:00 Fix doc typos in libraries/base - - - - - 1e3e21fa by Ben Gamari at 2023-05-08T17:15:43+01:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 73ffd6c3 by Cheng Shao at 2023-05-08T17:15:43+01:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - b856ddcf by Cheng Shao at 2023-05-08T17:15:43+01:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 78853fc6 by Cheng Shao at 2023-05-08T17:15:43+01:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 97545a7f by Bodigrim at 2023-05-08T17:15:43+01:00 Add since pragma to Data.Functor.unzip - - - - - 7e051fd0 by Soham Chowdhury at 2023-05-08T17:15:43+01:00 More informative errors for bad imports (#21826) - - - - - c8cc116e by Josh Meredith at 2023-05-08T17:15:43+01:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - c30ed397 by Josh Meredith at 2023-05-08T17:15:43+01:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 9e314f96 by Andrei Borzenkov at 2023-05-08T17:15:43+01:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - 0264500d by Ben Gamari at 2023-05-08T17:15:43+01:00 ghc-toolchain: Initial commit - - - - - 71e7e410 by Ben Gamari at 2023-05-08T17:15:43+01:00 configure: Rip out Solaris dyld check Solaris 11 was released over a decade ago and, moreover, I doubt we have any Solaris users - - - - - ace2b427 by Ben Gamari at 2023-05-08T17:15:43+01:00 Move via-C flags into GHC - - - - - afce352f by Ben Gamari at 2023-05-08T17:15:44+01:00 Rip out runtime linker/compiler checks - - - - - 44f3e1fd by Ben Gamari at 2023-05-08T17:18:44+01:00 configure: Rip out toolchain selection logic - - - - - 199d5bd3 by Ben Gamari at 2023-05-08T17:18:46+01:00 Fixes - - - - - c12c0877 by Rodrigo Mesquita at 2023-05-08T17:18:46+01:00 ghc-toolchain: Rename readProcess to readProcessStdout Fixes bugs regarding a translation from the original autconf program that failed to account for the exit code. The longer name reenforces that we really only care about the stdout, and the exit code and stderr of the program are irrelevant for the case. - - - - - 58aab98e by Rodrigo Mesquita at 2023-05-08T17:18:46+01:00 Re-introduce ld-override option - - - - - c4f5f4e7 by Rodrigo Mesquita at 2023-05-08T17:19:34+01:00 ROMES:WIP - - - - - 592edddc by Rodrigo Mesquita at 2023-05-08T17:19:35+01:00 ghc-toolchain library and usage in hadrian flags - - - - - 3237a7c5 by Rodrigo Mesquita at 2023-05-08T17:19:35+01:00 ROMES: WIP - - - - - cb0b101f by Rodrigo Mesquita at 2023-05-08T17:20:01+01:00 Re-introduce flags in hadrian config - - - - - f82e5efe by Rodrigo Mesquita at 2023-05-08T17:20:02+01:00 ROMES WIP - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/generate_job_metadata - .gitlab/generate_jobs - .gitlab/jobs.yaml - .gitmodules - cabal.project-reinstall - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/Wasm/Types.hs - compiler/GHC/CmmToAsm/Wasm/Utils.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core/ConLike.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/InstEnv.hs - compiler/GHC/Core/LateCC.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8a95b770fa4b1f4eba4ff4c3479f62a1168a4e1...f82e5efec2451ff02b71d3bba6c86d85ff1269cf -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8a95b770fa4b1f4eba4ff4c3479f62a1168a4e1...f82e5efec2451ff02b71d3bba6c86d85ff1269cf You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 16:44:34 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 12:44:34 -0400 Subject: [Git][ghc/ghc][wip/romes/target-has-rts-linker] Move "target has RTS linker" out of settings Message-ID: <645926f229ba3_38ffda56a36c9447441@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/target-has-rts-linker at Glasgow Haskell Compiler / GHC Commits: 56471f9a by Rodrigo Mesquita at 2023-05-08T17:44:25+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Closes #23361 - - - - - 9 changed files: - compiler/GHC/Driver/Session.hs - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -4727,8 +4727,9 @@ compilerInfo dflags ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), - ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), + ("Have native code generator", showBool $ platformNcgSupported platform), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make at . @@ -4769,6 +4770,23 @@ compilerInfo dflags expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd +-- | Does this target have an RTS linker? +-- Romes: Perhaps not the best place for the function +platformHasRTSLinker :: Platform -> Bool +-- NO for powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) +platformHasRTSLinker p = case archOS_arch (platformArchOS p) of + ArchPPC -> False -- What about powerpc other than powerpc-ibm-aix*? + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False -- What about s390x other than s390x-ibm-linux? + ArchRISCV64 -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + ArchWasm32 -> False + _ -> True + + + -- | Get target profile targetProfile :: DynFlags -> Profile targetProfile dflags = Profile (targetPlatform dflags) (ways dflags) ===================================== configure.ac ===================================== @@ -330,18 +330,6 @@ if test x"$TablesNextToCode" = xYES; then fi AC_SUBST(TablesNextToCode) -dnl ** Does target have runtime linker support? -dnl -------------------------------------------------------------- -case "$target" in - powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) - TargetHasRTSLinker=NO - ;; - *) - TargetHasRTSLinker=YES - ;; -esac -AC_SUBST(TargetHasRTSLinker) - # Requires FPTOOLS_SET_PLATFORMS_VARS to be run first. FP_FIND_ROOT ===================================== distrib/configure.ac.in ===================================== @@ -20,9 +20,6 @@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ -TargetHasRTSLinker=@TargetHasRTSLinker@ -AC_SUBST(TargetHasRTSLinker) - TargetHasLibm=@TargetHasLibm@ AC_SUBST(TargetHasLibm) ===================================== hadrian/bindist/Makefile ===================================== @@ -116,7 +116,6 @@ lib/settings : config.mk @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ - @echo ',("target has RTS linker", "$(TargetHasRTSLinker)")' >> $@ @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ @echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -253,7 +253,6 @@ TargetWordBigEndian = @TargetWordBigEndian@ TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ TargetHasIdentDirective = @TargetHasIdentDirective@ TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -173,7 +173,6 @@ target-word-big-endian = @TargetWordBigEndian@ target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@ target-has-ident-directive = @TargetHasIdentDirective@ target-has-subsections-via-symbols = @TargetHasSubsectionsViaSymbols@ -target-has-rts-linker = @TargetHasRTSLinker@ target-has-libm = @TargetHasLibm@ target-arm-version = @ARM_ISA@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -79,7 +79,6 @@ data Setting = BuildArch | TargetOsHaskell | TargetArmVersion | TargetWordSize - | TargetHasRtsLinker | BourneShell -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). @@ -181,7 +180,6 @@ setting key = lookupSystemConfig $ case key of TargetArchHaskell -> "target-arch-haskell" TargetOsHaskell -> "target-os-haskell" TargetWordSize -> "target-word-size" - TargetHasRtsLinker -> "target-has-rts-linker" BourneShell -> "bourne-shell" bootIsStage0 :: Stage -> Stage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -451,7 +451,6 @@ generateSettings = do , ("target has GNU nonexec stack", expr $ lookupSystemConfig "target-has-gnu-nonexec-stack") , ("target has .ident directive", expr $ lookupSystemConfig "target-has-ident-directive") , ("target has subsections via symbols", expr $ lookupSystemConfig "target-has-subsections-via-symbols") - , ("target has RTS linker", expr $ lookupSystemConfig "target-has-rts-linker") , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) , ("LLVM target", getSetting LlvmTarget) ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -126,7 +126,10 @@ inTreeCompilerArgs stg = do libdir <- System.FilePath.normalise . (top -/-) <$> stageLibPath stg - rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker + -- romes: Dear reviewer, I'm not sure if it's OK to do this here, but we no + -- longer "know" the information, we can only query either ghc --info, or + -- the test settings (which indirectly queried the ghc --info) + rtsLinker <- getBooleanSetting TestGhcWithRtsLinker return TestCompilerArgs{..} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56471f9a4630890c2d545e2102ee19c5d7465da8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56471f9a4630890c2d545e2102ee19c5d7465da8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 17:00:31 2023 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Mon, 08 May 2023 13:00:31 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/T17284 Message-ID: <64592aafc9be3_38ffda55c6ade04801d@gitlab.mail> Krzysztof Gogolewski pushed new branch wip/T17284 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T17284 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 17:58:35 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Mon, 08 May 2023 13:58:35 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/decode-cloned-stack-save Message-ID: <6459384bec81_38ffda59d3624849726@gitlab.mail> Sven Tennie pushed new branch wip/decode-cloned-stack-save at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/decode-cloned-stack-save You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 17:59:30 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 13:59:30 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] ghc-toolchain: UseLibFFI, LdCompactUnwind, LdFileList Message-ID: <645938825234c_38ffda59f3f968498442@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: 370defde by Rodrigo Mesquita at 2023-05-08T18:59:00+01:00 ghc-toolchain: UseLibFFI, LdCompactUnwind, LdFileList A more complete ghc-toolchain. Added configuration of: * Use libffi for adjustors * Supports compact unwind * Supports filelist - - - - - 7 changed files: - configure.ac - − m4/ghc_adjustors_method.m4 - utils/ghc-toolchain/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs - utils/ghc-toolchain/src/GHC/Toolchain/Prelude.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs Changes: ===================================== configure.ac ===================================== @@ -979,14 +979,14 @@ AC_DEFINE_UNQUOTED([RTS_LINKER_USE_MMAP], [$RtsLinkerUseMmap], [Use mmap in the runtime linker]) -# TODO: Unregisterised, TablesNextToCode -TablesNextToCode=YES -AC_SUBST([TablesNextToCode]) -Unregisterised=YES -AC_SUBST([Unregisterised]) - +AC_ARG_ENABLE(libffi-adjustors, + [AS_HELP_STRING( + [--enable-libffi-adjustors], + [Force use of libffi for adjustors, even on platforms which have support for more efficient, native adjustors.])], + UseLibffiForAdjustors=$enableval, + dnl do nothing +) -GHC_ADJUSTORS_METHOD([Target]) AC_SUBST([UseLibffiForAdjustors]) dnl ** Other RTS features ===================================== m4/ghc_adjustors_method.m4 deleted ===================================== @@ -1,49 +0,0 @@ -dnl GHC_ADJUSTORS_METHOD(Platform) -dnl -------------------------------------------------------------- -dnl Use libffi for adjustors? -AC_DEFUN([GHC_ADJUSTORS_METHOD], -[ - case [$]{$1[Arch]} in - i386|x86_64) - # We have native adjustor support on these platforms - HaveNativeAdjustor=yes - ;; - *) - HaveNativeAdjustor=no - ;; - esac - - AC_ARG_ENABLE(libffi-adjustors, - [AS_HELP_STRING( - [--enable-libffi-adjustors], - [Force use of libffi for adjustors, even on platforms which have support for more efficient, native adjustors.])], - UseLibffiForAdjustors=$enableval, - dnl do nothing - ) - - AC_MSG_CHECKING([whether to use libffi for adjustors]) - if test "$UseLibffiForAdjustors" = "yes" ; then - # Use libffi is the user explicitly requested it - AdjustorType="libffi" - elif test "$HaveNativeAdjustor" = "yes"; then - # Otherwise if we have a native adjustor implementation use that - AdjustorType="native" - else - # If we don't have a native adjustor implementation then default to libffi - AdjustorType="libffi" - fi - - case "$AdjustorType" in - libffi) - UseLibffiForAdjustors=YES - AC_MSG_RESULT([yes]) - ;; - native) - UseLibffiForAdjustors=NO - AC_MSG_RESULT([no]) - ;; - *) - AC_MSG_ERROR([Internal error: Invalid AdjustorType]) - exit 1 - esac -]) ===================================== utils/ghc-toolchain/Main.hs ===================================== @@ -44,6 +44,7 @@ data Opts = Opts , optDllwrap :: ProgOpt , optUnregisterised :: Maybe Bool , optTablesNextToCode :: Maybe Bool + , optUseLibFFIForAjdustors :: Maybe Bool , optLdOverride :: Maybe Bool , optVerbosity :: Int , optKeepTemp :: Bool @@ -100,6 +101,9 @@ _optUnregisterised = Lens optUnregisterised (\x o -> o {optUnregisterised=x}) _optTablesNextToCode :: Lens Opts (Maybe Bool) _optTablesNextToCode = Lens optTablesNextToCode (\x o -> o {optTablesNextToCode=x}) +_optUseLibffiForAdjustors :: Lens Opts (Maybe Bool) +_optUseLibffiForAdjustors = Lens optUseLibffiForAdjustors (\x o -> o {optUseLibffiForAdjustors=x}) + _optLdOvveride :: Lens Opts (Maybe Bool) _optLdOvveride = Lens optLdOverride (\x o -> o {optLdOverride=x}) @@ -119,6 +123,7 @@ options = concat [ enableDisable "unregisterised" "unregisterised backend" _optUnregisterised , enableDisable "tables-next-to-code" "Tables-next-to-code optimisation" _optTablesNextToCode + , enableDisable "libffi-adjustors" "Force use of libffi for adjustors, even on platforms which have support for more efficient, native adjustors." _optTablesNextToCode , enableDisable "ld-override" "override gcc's default linker" _optLdOvveride ] ++ concat @@ -250,6 +255,26 @@ determineTablesNextToCode archOs unreg userReq = where tntcSupported = tablesNextToCodeSupported archOs +determineUseLibFFIForAdjustors :: ArchOS + -> Maybe Bool -- ^ Enable/disable option --libffi-adjustors + -> M Bool +determineUseLibFFIForAdjustors archOs mb = checking "whether to use libffi for adjustors" $ + case mb of + True -> + -- The user explicitly requested it + pure True + + _ -> + -- If don't have a native adjustor implementation we use libffi + pure (not . archHasNativeAdjustors $ archOS_arch archOs) -- If we + +archHasNativeAdjustors :: Arch -> Bool +archHasNativeAdjustors = \case + ArchX86 -> True + ArchX86_64 -> True + _ -> False + + mkTarget :: Opts -> M Target mkTarget opts = do cc0 <- findCc (optCc opts) @@ -290,6 +315,7 @@ mkTarget opts = do tgtUnregisterised <- determineUnregisterised archOs (optUnregisterised opts) tgtTablesNextToCode <- determineTablesNextToCode archOs tgtUnregisterised (optTablesNextToCode opts) + tgtUseLibffi <- determineUseLibFFIForAdjustors archOs (optUseLibFFIForAjdustors opts) when tgtUnregisterised $ do -- The via-C code generator requires these let prog = "int main(int argc, char** argv) { return 0; }I" @@ -314,6 +340,7 @@ mkTarget opts = do , tgtEndianness , tgtUnregisterised , tgtTablesNextToCode + , tgtUseLibffi , tgtSymbolsHaveLeadingUnderscore , tgtSupportsSubsectionsViaSymbols , tgtSupportsIdentDirective ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs ===================================== @@ -12,6 +12,7 @@ module GHC.Toolchain.Monad -- * File I/O , readFile , writeFile + , appendFile , createFile -- * Logging @@ -21,7 +22,7 @@ module GHC.Toolchain.Monad , withLogContext ) where -import Prelude hiding (readFile, writeFile) +import Prelude hiding (readFile, writeFile, appendFile) import qualified Prelude import Control.Applicative @@ -31,7 +32,9 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.Except as Except -import System.IO hiding (readFile, writeFile) +import System.IO hiding (readFile, writeFile, appendFile) +-- import qualified System.Directory + data Env = Env { verbosity :: Int , targetPrefix :: Maybe String @@ -98,6 +101,14 @@ readFile path = liftIO $ Prelude.readFile path writeFile :: FilePath -> String -> M () writeFile path s = liftIO $ Prelude.writeFile path s +appendFile :: FilePath -> String -> M () +appendFile path s = liftIO $ Prelude.appendFile path s + +-- copyFile :: FilePath -- ^ Source file +-- -> FilePath -- ^ Destination file +-- -> M () +-- copyFile src dst = liftIO $ System.Directory.copyFile src dst + -- | Create an empty file. createFile :: FilePath -> M () createFile path = writeFile path "" ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Prelude.hs ===================================== @@ -8,4 +8,4 @@ module GHC.Toolchain.Prelude import GHC.Toolchain.Monad import GHC.Toolchain.Lens import Control.Applicative -import Prelude hiding (writeFile, readFile) +import Prelude hiding (writeFile, readFile, appendFile) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -42,15 +42,15 @@ data Target = Target , tgtUnregisterised :: Bool , tgtTablesNextToCode :: Bool -- , tgtHasRtsLinker :: Bool -- NO NEED! Rebase on MR removing it. - -- , tgtHasThreadedRts :: Bool - , tgtUseLibffi :: Bool -- We need to know whether or not to include libffi headers, and generate additional code for it + -- , tgtHasThreadedRts :: Bool -- Do we need this for each target? Or just when bootstrapping? + , tgtUseLibffiForAdjustors :: Bool -- We need to know whether or not to include libffi headers, and generate additional code for it -- C toolchain , tgtCCompiler :: Cc , tgtCxxCompiler :: Cxx , tgtCPreprocessor :: Cpp -- if hadrian depends on Cpp (not HsCpp flags) then this isn't sufficient , tgtCCompilerLink :: CcLink - -- , tgtLd :: Program -- needed? probably not + -- , tgtLd :: Program -- needed? probably not, we link always through the c compiler -- , tgtLdIsGnuLd :: Bool -- After rebase on LdHasGcSections (and renamed) , tgtAr :: Ar , tgtRanlib :: Maybe Ranlib -- Most ar implementations do good things by default without ranlib so don't need it ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -34,10 +34,12 @@ findCcLink progOpt ldOverride archOs cc readelf = checking "for C compiler for l -- If not then try to find a decent linker on our own rawCcLink <- findProgram "C compiler for linking" progOpt [prgPath $ ccProgram cc] findLinkFlags ldOverride cc rawCcLink <|> pure rawCcLink - ccLinkSupportsNoPie <- checkSupportsNoPie ccLinkProgram + ccLinkSupportsNoPie <- checkSupportsNoPie ccLinkProgram + ccLinkSupportsCompactUnwind <- checkSupportsCompactUnwind cc ccLinkProgram + ccLinkSupportsFilelist <- checkSupportsFilelist cc ccLinkProgram checkBfdCopyBug archOs cc readelf ccLinkProgram ccLinkProgram <- addPlatformDepLinkFlags archOs cc ccLinkProgram - return $ CcLink {ccLinkProgram, ccLinkSupportsNoPie} + return $ CcLink {ccLinkProgram, ccLinkSupportsNoPie, ccLinkSupportsCompactUnwind, ccLinkSupportsFilelist} -- | Try to convince @cc@ to use a more efficient linker than @bfd.ld@ findLinkFlags :: Maybe Bool -> Cc -> Program -> M Program @@ -79,8 +81,9 @@ doLinkerSearch = False #endif checkSupportsNoPie :: Program -> M Bool -checkSupportsNoPie ccLink = withTempDir $ \dir -> do - let test_c = dir "test.o" +checkSupportsNoPie ccLink = checking "whether CC supports -no-pie" $ + withTempDir $ \dir -> do + let test_c = dir "test.c" writeFile test_c "int main() { return 0; }" let test = dir "test" @@ -91,6 +94,41 @@ checkSupportsNoPie ccLink = withTempDir $ \dir -> do then return False else return True +checkSupportsCompactUnwind :: Cc -> Program -> M Bool +checkSupportsCompactUnwind cc ccLink = checking "whether ld understands -no_compact_unwind" $ + withTempDir $ \dir -> do + let test_c = dir "test.c" + test_o = dir "test.o" + test2_o = dir "test2.o" + writeFile test_c "int foo() { return 0; }" + callProgram (ccProgram cc) ["-c", test_c] + exitCode <- runProgram ccLink ["-r", "-no_compact_unwind", "-o", test2_o, test_o] + pure $ isSuccess exitCode + + +checkSupportsFilelist :: Cc -> Program -> M Bool +checkSupportsFilelist cc ccLink = checking "whether ld understands -filelist" $ + withTempDir $ \dir -> do + let test_o = dir "test.o" + test1_c = dir "test1.c" + test2_c = dir "test2.c" + test1_o = dir "test1.o" + test2_o = dir "test2.o" + test_ofiles = dir "test.o-files" + + writeFile test1_c "int foo() { return 0; }" + writeFile test2_c "int bar() { return 0; }" + + callProgram (ccProgram cc) ["-c", test1_c] + callProgram (ccProgram cc) ["-c", test2_c] + + writeFile test_ofiles test1_o -- write the filename test1_o to the test_ofiles file + appendFile test_ofiles test2_o -- append the filename test2_o to the test_ofiles file + + exitCode <- runProgram ccLink ["-r", "-filelist", test_ofiles, "-o", test_o] + + pure $ isSuccess exitCode + -- | Check whether linking works. checkLinkWorks :: Cc -> Program -> M () checkLinkWorks cc ccLink = withTempDir $ \dir -> do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/370defde2972c1e5e83005eac2d9a53ca13a4f66 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/370defde2972c1e5e83005eac2d9a53ca13a4f66 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 18:05:42 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 14:05:42 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] ghc-toolchain: UseLibFFI, LdCompactUnwind, LdFileList Message-ID: <645939f6a02c0_38ffda5a64cef4501975@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: d1387b26 by Rodrigo Mesquita at 2023-05-08T19:05:32+01:00 ghc-toolchain: UseLibFFI, LdCompactUnwind, LdFileList A more complete ghc-toolchain. Added configuration of: * Use libffi for adjustors * Supports compact unwind * Supports filelist - - - - - 7 changed files: - configure.ac - − m4/ghc_adjustors_method.m4 - utils/ghc-toolchain/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs - utils/ghc-toolchain/src/GHC/Toolchain/Prelude.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs Changes: ===================================== configure.ac ===================================== @@ -979,14 +979,14 @@ AC_DEFINE_UNQUOTED([RTS_LINKER_USE_MMAP], [$RtsLinkerUseMmap], [Use mmap in the runtime linker]) -# TODO: Unregisterised, TablesNextToCode -TablesNextToCode=YES -AC_SUBST([TablesNextToCode]) -Unregisterised=YES -AC_SUBST([Unregisterised]) - +AC_ARG_ENABLE(libffi-adjustors, + [AS_HELP_STRING( + [--enable-libffi-adjustors], + [Force use of libffi for adjustors, even on platforms which have support for more efficient, native adjustors.])], + UseLibffiForAdjustors=$enableval, + dnl do nothing +) -GHC_ADJUSTORS_METHOD([Target]) AC_SUBST([UseLibffiForAdjustors]) dnl ** Other RTS features ===================================== m4/ghc_adjustors_method.m4 deleted ===================================== @@ -1,49 +0,0 @@ -dnl GHC_ADJUSTORS_METHOD(Platform) -dnl -------------------------------------------------------------- -dnl Use libffi for adjustors? -AC_DEFUN([GHC_ADJUSTORS_METHOD], -[ - case [$]{$1[Arch]} in - i386|x86_64) - # We have native adjustor support on these platforms - HaveNativeAdjustor=yes - ;; - *) - HaveNativeAdjustor=no - ;; - esac - - AC_ARG_ENABLE(libffi-adjustors, - [AS_HELP_STRING( - [--enable-libffi-adjustors], - [Force use of libffi for adjustors, even on platforms which have support for more efficient, native adjustors.])], - UseLibffiForAdjustors=$enableval, - dnl do nothing - ) - - AC_MSG_CHECKING([whether to use libffi for adjustors]) - if test "$UseLibffiForAdjustors" = "yes" ; then - # Use libffi is the user explicitly requested it - AdjustorType="libffi" - elif test "$HaveNativeAdjustor" = "yes"; then - # Otherwise if we have a native adjustor implementation use that - AdjustorType="native" - else - # If we don't have a native adjustor implementation then default to libffi - AdjustorType="libffi" - fi - - case "$AdjustorType" in - libffi) - UseLibffiForAdjustors=YES - AC_MSG_RESULT([yes]) - ;; - native) - UseLibffiForAdjustors=NO - AC_MSG_RESULT([no]) - ;; - *) - AC_MSG_ERROR([Internal error: Invalid AdjustorType]) - exit 1 - esac -]) ===================================== utils/ghc-toolchain/Main.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} module Main where @@ -44,6 +45,7 @@ data Opts = Opts , optDllwrap :: ProgOpt , optUnregisterised :: Maybe Bool , optTablesNextToCode :: Maybe Bool + , optUseLibFFIForAdjustors :: Maybe Bool , optLdOverride :: Maybe Bool , optVerbosity :: Int , optKeepTemp :: Bool @@ -66,6 +68,7 @@ emptyOpts = Opts , optWindres = po0 , optUnregisterised = Nothing , optTablesNextToCode = Nothing + , optUseLibFFIForAdjustors = Nothing , optLdOverride = Nothing -- See comment in Link on 'enableOverride'. Shouldn't we set the default here? , optVerbosity = 0 , optKeepTemp = False @@ -100,6 +103,9 @@ _optUnregisterised = Lens optUnregisterised (\x o -> o {optUnregisterised=x}) _optTablesNextToCode :: Lens Opts (Maybe Bool) _optTablesNextToCode = Lens optTablesNextToCode (\x o -> o {optTablesNextToCode=x}) +_optUseLibFFIForAdjustors :: Lens Opts (Maybe Bool) +_optUseLibFFIForAdjustors = Lens optUseLibFFIForAdjustors (\x o -> o {optUseLibFFIForAdjustors=x}) + _optLdOvveride :: Lens Opts (Maybe Bool) _optLdOvveride = Lens optLdOverride (\x o -> o {optLdOverride=x}) @@ -119,6 +125,7 @@ options = concat [ enableDisable "unregisterised" "unregisterised backend" _optUnregisterised , enableDisable "tables-next-to-code" "Tables-next-to-code optimisation" _optTablesNextToCode + , enableDisable "libffi-adjustors" "Force use of libffi for adjustors, even on platforms which have support for more efficient, native adjustors." _optUseLibFFIForAdjustors , enableDisable "ld-override" "override gcc's default linker" _optLdOvveride ] ++ concat @@ -250,6 +257,26 @@ determineTablesNextToCode archOs unreg userReq = where tntcSupported = tablesNextToCodeSupported archOs +determineUseLibFFIForAdjustors :: ArchOS + -> Maybe Bool -- ^ Enable/disable option --libffi-adjustors + -> M Bool +determineUseLibFFIForAdjustors archOs mb = checking "whether to use libffi for adjustors" $ + case mb of + Just True -> + -- The user explicitly requested it + pure True + + _ -> + -- If don't have a native adjustor implementation we use libffi + pure (not . archHasNativeAdjustors $ archOS_arch archOs) -- If we + +archHasNativeAdjustors :: Arch -> Bool +archHasNativeAdjustors = \case + ArchX86 -> True + ArchX86_64 -> True + _ -> False + + mkTarget :: Opts -> M Target mkTarget opts = do cc0 <- findCc (optCc opts) @@ -290,6 +317,7 @@ mkTarget opts = do tgtUnregisterised <- determineUnregisterised archOs (optUnregisterised opts) tgtTablesNextToCode <- determineTablesNextToCode archOs tgtUnregisterised (optTablesNextToCode opts) + tgtUseLibffi <- determineUseLibFFIForAdjustors archOs (optUseLibFFIForAdjustors opts) when tgtUnregisterised $ do -- The via-C code generator requires these let prog = "int main(int argc, char** argv) { return 0; }I" @@ -314,6 +342,7 @@ mkTarget opts = do , tgtEndianness , tgtUnregisterised , tgtTablesNextToCode + , tgtUseLibffiForAdjustors = tgtUseLibffi , tgtSymbolsHaveLeadingUnderscore , tgtSupportsSubsectionsViaSymbols , tgtSupportsIdentDirective ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Monad.hs ===================================== @@ -12,6 +12,7 @@ module GHC.Toolchain.Monad -- * File I/O , readFile , writeFile + , appendFile , createFile -- * Logging @@ -21,7 +22,7 @@ module GHC.Toolchain.Monad , withLogContext ) where -import Prelude hiding (readFile, writeFile) +import Prelude hiding (readFile, writeFile, appendFile) import qualified Prelude import Control.Applicative @@ -31,7 +32,9 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.Except as Except -import System.IO hiding (readFile, writeFile) +import System.IO hiding (readFile, writeFile, appendFile) +-- import qualified System.Directory + data Env = Env { verbosity :: Int , targetPrefix :: Maybe String @@ -98,6 +101,14 @@ readFile path = liftIO $ Prelude.readFile path writeFile :: FilePath -> String -> M () writeFile path s = liftIO $ Prelude.writeFile path s +appendFile :: FilePath -> String -> M () +appendFile path s = liftIO $ Prelude.appendFile path s + +-- copyFile :: FilePath -- ^ Source file +-- -> FilePath -- ^ Destination file +-- -> M () +-- copyFile src dst = liftIO $ System.Directory.copyFile src dst + -- | Create an empty file. createFile :: FilePath -> M () createFile path = writeFile path "" ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Prelude.hs ===================================== @@ -8,4 +8,4 @@ module GHC.Toolchain.Prelude import GHC.Toolchain.Monad import GHC.Toolchain.Lens import Control.Applicative -import Prelude hiding (writeFile, readFile) +import Prelude hiding (writeFile, readFile, appendFile) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -42,15 +42,15 @@ data Target = Target , tgtUnregisterised :: Bool , tgtTablesNextToCode :: Bool -- , tgtHasRtsLinker :: Bool -- NO NEED! Rebase on MR removing it. - -- , tgtHasThreadedRts :: Bool - , tgtUseLibffi :: Bool -- We need to know whether or not to include libffi headers, and generate additional code for it + -- , tgtHasThreadedRts :: Bool -- Do we need this for each target? Or just when bootstrapping? + , tgtUseLibffiForAdjustors :: Bool -- We need to know whether or not to include libffi headers, and generate additional code for it -- C toolchain , tgtCCompiler :: Cc , tgtCxxCompiler :: Cxx , tgtCPreprocessor :: Cpp -- if hadrian depends on Cpp (not HsCpp flags) then this isn't sufficient , tgtCCompilerLink :: CcLink - -- , tgtLd :: Program -- needed? probably not + -- , tgtLd :: Program -- needed? probably not, we link always through the c compiler -- , tgtLdIsGnuLd :: Bool -- After rebase on LdHasGcSections (and renamed) , tgtAr :: Ar , tgtRanlib :: Maybe Ranlib -- Most ar implementations do good things by default without ranlib so don't need it ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -34,10 +34,12 @@ findCcLink progOpt ldOverride archOs cc readelf = checking "for C compiler for l -- If not then try to find a decent linker on our own rawCcLink <- findProgram "C compiler for linking" progOpt [prgPath $ ccProgram cc] findLinkFlags ldOverride cc rawCcLink <|> pure rawCcLink - ccLinkSupportsNoPie <- checkSupportsNoPie ccLinkProgram + ccLinkSupportsNoPie <- checkSupportsNoPie ccLinkProgram + ccLinkSupportsCompactUnwind <- checkSupportsCompactUnwind cc ccLinkProgram + ccLinkSupportsFilelist <- checkSupportsFilelist cc ccLinkProgram checkBfdCopyBug archOs cc readelf ccLinkProgram ccLinkProgram <- addPlatformDepLinkFlags archOs cc ccLinkProgram - return $ CcLink {ccLinkProgram, ccLinkSupportsNoPie} + return $ CcLink {ccLinkProgram, ccLinkSupportsNoPie, ccLinkSupportsCompactUnwind, ccLinkSupportsFilelist} -- | Try to convince @cc@ to use a more efficient linker than @bfd.ld@ findLinkFlags :: Maybe Bool -> Cc -> Program -> M Program @@ -79,8 +81,9 @@ doLinkerSearch = False #endif checkSupportsNoPie :: Program -> M Bool -checkSupportsNoPie ccLink = withTempDir $ \dir -> do - let test_c = dir "test.o" +checkSupportsNoPie ccLink = checking "whether CC supports -no-pie" $ + withTempDir $ \dir -> do + let test_c = dir "test.c" writeFile test_c "int main() { return 0; }" let test = dir "test" @@ -91,6 +94,41 @@ checkSupportsNoPie ccLink = withTempDir $ \dir -> do then return False else return True +checkSupportsCompactUnwind :: Cc -> Program -> M Bool +checkSupportsCompactUnwind cc ccLink = checking "whether ld understands -no_compact_unwind" $ + withTempDir $ \dir -> do + let test_c = dir "test.c" + test_o = dir "test.o" + test2_o = dir "test2.o" + writeFile test_c "int foo() { return 0; }" + callProgram (ccProgram cc) ["-c", test_c] + exitCode <- runProgram ccLink ["-r", "-no_compact_unwind", "-o", test2_o, test_o] + pure $ isSuccess exitCode + + +checkSupportsFilelist :: Cc -> Program -> M Bool +checkSupportsFilelist cc ccLink = checking "whether ld understands -filelist" $ + withTempDir $ \dir -> do + let test_o = dir "test.o" + test1_c = dir "test1.c" + test2_c = dir "test2.c" + test1_o = dir "test1.o" + test2_o = dir "test2.o" + test_ofiles = dir "test.o-files" + + writeFile test1_c "int foo() { return 0; }" + writeFile test2_c "int bar() { return 0; }" + + callProgram (ccProgram cc) ["-c", test1_c] + callProgram (ccProgram cc) ["-c", test2_c] + + writeFile test_ofiles test1_o -- write the filename test1_o to the test_ofiles file + appendFile test_ofiles test2_o -- append the filename test2_o to the test_ofiles file + + exitCode <- runProgram ccLink ["-r", "-filelist", test_ofiles, "-o", test_o] + + pure $ isSuccess exitCode + -- | Check whether linking works. checkLinkWorks :: Cc -> Program -> M () checkLinkWorks cc ccLink = withTempDir $ \dir -> do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1387b26399d0fa2dce2e6948afbab3ba80dfb0a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1387b26399d0fa2dce2e6948afbab3ba80dfb0a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 18:31:43 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Mon, 08 May 2023 14:31:43 -0400 Subject: [Git][ghc/ghc][wip/decode_cloned_stack] 6 commits: Serialize CmmRetInfo in .rodata Message-ID: <6459400f166f4_38ffda5c83e65c5163c1@gitlab.mail> Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC Commits: 208f181d by Sven Tennie at 2023-05-08T18:10:03+00:00 Serialize CmmRetInfo in .rodata The handling of case was missing. - - - - - 715eebf6 by Sven Tennie at 2023-05-08T18:12:35+00:00 Reference StgRetFun payload by its struct field address This is easier to grasp than relative pointer offsets. - - - - - b529e7cf by Sven Tennie at 2023-05-08T18:21:14+00:00 Better variable name: u -> frame The 'u' was likely introduced by copy'n'paste. - - - - - eefa9f12 by Sven Tennie at 2023-05-08T18:22:59+00:00 Make checkSTACK() public Such that it can also be used in tests. - - - - - 2c9f1a36 by Sven Tennie at 2023-05-08T18:26:07+00:00 Publish stack related fields in DerivedConstants.h These will be used in ghc-heap to decode these parts of the stack. - - - - - e778d832 by Sven Tennie at 2023-05-08T18:29:32+00:00 ghc-heap: Decode StgStack and its stack frames Previously, ghc-heap could only decode heap closures. The approach is explained in detail in note [Decoding the stack]. - - - - - 22 changed files: - compiler/GHC/Cmm/CLabel.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc - + libraries/ghc-heap/GHC/Exts/Stack.hs - + libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc - + libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - + libraries/ghc-heap/cbits/Stack.c - + libraries/ghc-heap/cbits/Stack.cmm - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-heap/tests/TestUtils.hs - libraries/ghc-heap/tests/all.T - + libraries/ghc-heap/tests/stack_big_ret.hs - + libraries/ghc-heap/tests/stack_misc_closures.hs - + libraries/ghc-heap/tests/stack_misc_closures_c.c - + libraries/ghc-heap/tests/stack_misc_closures_prim.cmm - + libraries/ghc-heap/tests/stack_stm_frames.hs - + libraries/ghc-heap/tests/stack_underflow.hs - rts/Printer.c - rts/include/rts/storage/InfoTables.h - rts/sm/Sanity.c - rts/sm/Sanity.h - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/Cmm/CLabel.hs ===================================== @@ -797,6 +797,7 @@ isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True -- info table defined in cmm (.cmm) isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True +isSomeRODataLabel (CmmLabel _ _ _ CmmRetInfo) = True isSomeRODataLabel _lbl = False -- | Whether label is points to some kind of info table ===================================== libraries/ghc-heap/GHC/Exts/Heap/Closures.hs ===================================== @@ -15,9 +15,18 @@ module GHC.Exts.Heap.Closures ( , WhatNext(..) , WhyBlocked(..) , TsoFlags(..) + , RetFunType(..) , allClosures , closureSize + -- * Stack + , StgStackClosure + , GenStgStackClosure(..) + , StackFrame + , GenStackFrame(..) + , StackField + , GenStackField(..) + -- * Boxes , Box(..) , areBoxesEqual @@ -95,7 +104,6 @@ areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of ------------------------------------------------------------------------ -- Closures - type Closure = GenClosure Box -- | This is the representation of a Haskell value on the heap. It reflects @@ -354,8 +362,148 @@ data GenClosure b | UnsupportedClosure { info :: !StgInfoTable } + + -- | A primitive word from a bitmap encoded stack frame payload + -- + -- The type itself cannot be restored (i.e. it might represent a Word8# + -- or an Int#). + | UnknownTypeWordSizedPrimitive + { wordVal :: !Word } deriving (Show, Generic, Functor, Foldable, Traversable) +type StgStackClosure = GenStgStackClosure Box + +-- | A decoded @StgStack@ with `StackFrame`s +-- +-- Stack related data structures (`GenStgStackClosure`, `GenStackField`, +-- `GenStackFrame`) are defined separately from `GenClosure` as their related +-- functions are very different. Though, both are closures in the sense of RTS +-- structures, their decoding logic differs: While it's safe to keep a reference +-- to a heap closure, the garbage collector does not update references to stack +-- located closures. +-- +-- Additionally, stack frames don't appear outside of the stack. Thus, keeping +-- `GenStackFrame` and `GenClosure` separated, makes these types more precise +-- (in the sense what values to expect.) +data GenStgStackClosure b = GenStgStackClosure + { ssc_info :: !StgInfoTable + , ssc_stack_size :: !Word32 -- ^ stack size in *words* + , ssc_stack_dirty :: !Word8 -- ^ non-zero => dirty + , ssc_stack_marking :: !Word8 + , ssc_stack :: ![GenStackFrame b] + } + deriving (Foldable, Functor, Generic, Show, Traversable) + +type StackField = GenStackField Box + +-- | Bitmap-encoded payload on the stack +data GenStackField b + -- | A non-pointer field + = StackWord !Word + -- | A pointer field + | StackBox !b + deriving (Foldable, Functor, Generic, Show, Traversable) + +type StackFrame = GenStackFrame Box + +-- | A single stack frame +data GenStackFrame b = + UpdateFrame + { info_tbl :: !StgInfoTable + , updatee :: !b + } + + | CatchFrame + { info_tbl :: !StgInfoTable + , exceptions_blocked :: !Word + , handler :: !b + } + + | CatchStmFrame + { info_tbl :: !StgInfoTable + , catchFrameCode :: !b + , handler :: !b + } + + | CatchRetryFrame + { info_tbl :: !StgInfoTable + , running_alt_code :: !Word + , first_code :: !b + , alt_code :: !b + } + + | AtomicallyFrame + { info_tbl :: !StgInfoTable + , atomicallyFrameCode :: !b + , result :: !b + } + + | UnderflowFrame + { info_tbl :: !StgInfoTable + , nextChunk :: !(GenStgStackClosure b) + } + + | StopFrame + { info_tbl :: !StgInfoTable } + + | RetSmall + { info_tbl :: !StgInfoTable + , stack_payload :: ![GenStackField b] + } + + | RetBig + { info_tbl :: !StgInfoTable + , stack_payload :: ![GenStackField b] + } + + | RetFun + { info_tbl :: !StgInfoTable + , retFunType :: !RetFunType + , retFunSize :: !Word + , retFunFun :: !b + , retFunPayload :: ![GenStackField b] + } + + | RetBCO + { info_tbl :: !StgInfoTable + , bco :: !b -- ^ always a BCOClosure + , bcoArgs :: ![GenStackField b] + } + deriving (Foldable, Functor, Generic, Show, Traversable) + +-- | Fun types according to @FunTypes.h@ +-- This `Enum` must be aligned with the values in @FunTypes.h at . +data RetFunType = + ARG_GEN | + ARG_GEN_BIG | + ARG_BCO | + ARG_NONE | + ARG_N | + ARG_P | + ARG_F | + ARG_D | + ARG_L | + ARG_V16 | + ARG_V32 | + ARG_V64 | + ARG_NN | + ARG_NP | + ARG_PN | + ARG_PP | + ARG_NNN | + ARG_NNP | + ARG_NPN | + ARG_NPP | + ARG_PNN | + ARG_PNP | + ARG_PPN | + ARG_PPP | + ARG_PPPP | + ARG_PPPPP | + ARG_PPPPPP | + ARG_PPPPPPP | + ARG_PPPPPPPP + deriving (Show, Eq, Enum, Generic) data PrimType = PInt ===================================== libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc ===================================== @@ -37,4 +37,4 @@ data StgInfoTable = StgInfoTable { tipe :: ClosureType, srtlen :: HalfWord, code :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) ===================================== libraries/ghc-heap/GHC/Exts/Stack.hs ===================================== @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +#if MIN_TOOL_VERSION_ghc(9,7,0) +{-# LANGUAGE RecordWildCards #-} + +module GHC.Exts.Stack + ( -- * Stack inspection + decodeStack, + stackFrameSize, + ) +where + +import GHC.Exts.Heap.Closures +import GHC.Exts.Stack.Constants +import GHC.Exts.Stack.Decode +import Prelude + +-- | Get the size of the `StackFrame` in words. +-- +-- Includes header and payload. Does not follow pointers. +stackFrameSize :: StackFrame -> Int +stackFrameSize (UpdateFrame {}) = sizeStgUpdateFrame +stackFrameSize (CatchFrame {}) = sizeStgCatchFrame +stackFrameSize (CatchStmFrame {}) = sizeStgCatchSTMFrame +stackFrameSize (CatchRetryFrame {}) = sizeStgCatchRetryFrame +stackFrameSize (AtomicallyFrame {}) = sizeStgAtomicallyFrame +stackFrameSize (RetSmall {..}) = sizeStgClosure + length stack_payload +stackFrameSize (RetBig {..}) = sizeStgClosure + length stack_payload +stackFrameSize (RetFun {..}) = sizeStgRetFunFrame + length retFunPayload +-- The one additional word is a pointer to the StgBCO in the closure's payload +stackFrameSize (RetBCO {..}) = sizeStgClosure + 1 + length bcoArgs +-- The one additional word is a pointer to the next stack chunk +stackFrameSize (UnderflowFrame {}) = sizeStgClosure + 1 +stackFrameSize _ = error "Unexpected stack frame type" + +#else +module GHC.Exts.Stack where +#endif ===================================== libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc ===================================== @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Exts.Stack.Constants where + +#if MIN_TOOL_VERSION_ghc(9,7,0) + +import Prelude + +#include "Rts.h" +#undef BLOCK_SIZE +#undef MBLOCK_SIZE +#undef BLOCKS_PER_MBLOCK +#include "DerivedConstants.h" + +newtype ByteOffset = ByteOffset { offsetInBytes :: Int } + deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord) + +newtype WordOffset = WordOffset { offsetInWords :: Int } + deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord) + +offsetStgCatchFrameHandler :: WordOffset +offsetStgCatchFrameHandler = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader) + +offsetStgCatchFrameExceptionsBlocked :: WordOffset +offsetStgCatchFrameExceptionsBlocked = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchFrame_exceptions_blocked) + (#size StgHeader) + +sizeStgCatchFrame :: Int +sizeStgCatchFrame = bytesToWords $ + (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader) + +offsetStgCatchSTMFrameCode :: WordOffset +offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader) + +offsetStgCatchSTMFrameHandler :: WordOffset +offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader) + +sizeStgCatchSTMFrame :: Int +sizeStgCatchSTMFrame = bytesToWords $ + (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader) + +offsetStgUpdateFrameUpdatee :: WordOffset +offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $ + (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader) + +sizeStgUpdateFrame :: Int +sizeStgUpdateFrame = bytesToWords $ + (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader) + +offsetStgAtomicallyFrameCode :: WordOffset +offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $ + (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader) + +offsetStgAtomicallyFrameResult :: WordOffset +offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $ + (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader) + +sizeStgAtomicallyFrame :: Int +sizeStgAtomicallyFrame = bytesToWords $ + (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader) + +offsetStgCatchRetryFrameRunningAltCode :: WordOffset +offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader) + +offsetStgCatchRetryFrameRunningFirstCode :: WordOffset +offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader) + +offsetStgCatchRetryFrameAltCode :: WordOffset +offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $ + (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader) + +sizeStgCatchRetryFrame :: Int +sizeStgCatchRetryFrame = bytesToWords $ + (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader) + +offsetStgRetFunFrameSize :: WordOffset +-- StgRetFun has no header, but only a pointer to the info table at the beginning. +offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size) + +offsetStgRetFunFrameFun :: WordOffset +offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun) + +offsetStgRetFunFramePayload :: WordOffset +offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload) + +sizeStgRetFunFrame :: Int +sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun) + +offsetStgBCOFrameInstrs :: ByteOffset +offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader) + +offsetStgBCOFrameLiterals :: ByteOffset +offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader) + +offsetStgBCOFramePtrs :: ByteOffset +offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader) + +offsetStgBCOFrameArity :: ByteOffset +offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader) + +offsetStgBCOFrameSize :: ByteOffset +offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader) + +offsetStgClosurePayload :: WordOffset +offsetStgClosurePayload = byteOffsetToWordOffset $ + (#const OFFSET_StgClosure_payload) + (#size StgHeader) + +sizeStgClosure :: Int +sizeStgClosure = bytesToWords (#size StgHeader) + +byteOffsetToWordOffset :: ByteOffset -> WordOffset +byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger + +bytesToWords :: Int -> Int +bytesToWords b = + if b `mod` bytesInWord == 0 then + fromIntegral $ b `div` bytesInWord + else + error "Unexpected struct alignment!" + +bytesInWord :: Int +bytesInWord = (#const SIZEOF_VOID_P) + +#endif ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -0,0 +1,444 @@ +{-# LANGUAGE CPP #-} +#if MIN_TOOL_VERSION_ghc(9,7,0) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module GHC.Exts.Stack.Decode + ( decodeStack, + ) +where + +import Control.Monad +import Data.Bits +import Data.Maybe +import Foreign +import GHC.Exts +import GHC.Exts.Heap (Box (..)) +import GHC.Exts.Heap.ClosureTypes +import GHC.Exts.Heap.Closures + ( RetFunType (..), + StackFrame, + GenStackFrame (..), + StgStackClosure, + GenStgStackClosure (..), + StackField, + GenStackField(..) + ) +import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS) +import GHC.Exts.Heap.InfoTable +import GHC.Exts.Stack.Constants +import GHC.IO (IO (..)) +import GHC.Stack.CloneStack +import GHC.Word +import Prelude + +{- Note [Decoding the stack] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + +The stack is represented by a chain of StgStack closures. Each of these closures +is subject to garbage collection. I.e. they can be moved in memory (in a +simplified perspective) at any time. + +The array of closures inside an StgStack (that makeup the execution stack; the +stack frames) is moved as bare memory by the garbage collector. References +(pointers) to stack frames are not updated by the garbage collector. + +As the StgStack closure is moved as whole, the relative offsets inside it stay +the same. (Though, the absolute addresses change!) + +Decoding +======== + +Stack frames are defined by their `StackSnapshot#` (`StgStack*` in RTS) and +their relative offset. This tuple is described by `StackFrameLocation`. + +`StackFrame` is an ADT for decoded stack frames. Regarding payload and fields we +have to deal with three cases: + +- If the payload can only be a closure, we put it in a `Box` for later decoding + by the heap closure functions. + +- If the payload can either be a closure or a word-sized value (this happens for + bitmap-encoded payloads), we use a `StackField` which is a sum type to + represent either a `Word` or a `Box`. + +- Fields that are just simple (i.e. non-closure) values are decoded as such. + +The decoding happens in two phases: + +1. The whole stack is decoded into `StackFrameLocation`s. + +2. All `StackFrameLocation`s are decoded into `StackFrame`s. + +`StackSnapshot#` parameters are updated by the garbage collector and thus safe +to hand around. + +The head of the stack frame array has offset (index) 0. To traverse the stack +frames the latest stack frame's offset is incremented by the closure size. The +unit of the offset is machine words (32bit or 64bit.) + +IO +== + +Unfortunately, ghc-heap decodes `Closure`s in `IO`. This leads to `StackFrames` +also being decoded in `IO`, due to references to `Closure`s. + +Technical details +================= + +- All access to StgStack/StackSnapshot# closures is made through Cmm code. This + keeps the closure from being moved by the garbage collector during the + operation. + +- As StgStacks are mainly used in Cmm and C code, much of the decoding logic is + implemented in Cmm and C. It's just easier to reuse existing helper macros and + functions, than reinventing them in Haskell. + +- Offsets and sizes of closures are imported from DerivedConstants.h via HSC. + This keeps the code very portable. +-} + +foreign import prim "getUnderflowFrameNextChunkzh" + getUnderflowFrameNextChunk# :: + StackSnapshot# -> Word# -> StackSnapshot# + +getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> StackSnapshot +getUnderflowFrameNextChunk stackSnapshot# index = + StackSnapshot (getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index)) + +foreign import prim "getWordzh" + getWord# :: + StackSnapshot# -> Word# -> Word# + +getWord :: StackSnapshot# -> WordOffset -> Word +getWord stackSnapshot# index = + W# (getWord# stackSnapshot# (wordOffsetToWord# index)) + +foreign import prim "getRetFunTypezh" getRetFunType# :: StackSnapshot# -> Word# -> Word# + +getRetFunType :: StackSnapshot# -> WordOffset -> RetFunType +getRetFunType stackSnapshot# index = + toEnum . fromInteger . toInteger $ + W# (getRetFunType# stackSnapshot# (wordOffsetToWord# index)) + +-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@) +-- +-- The first two arguments identify the location of the frame on the stack. +-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size. +type LargeBitmapGetter = StackSnapshot# -> Word# -> (# Addr#, Word# #) + +foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter + +foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter + +foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter + +-- | Gets contents of a small bitmap (fitting in one @StgWord@) +-- +-- The first two arguments identify the location of the frame on the stack. +-- Returned is the bitmap and it's size. +type SmallBitmapGetter = StackSnapshot# -> Word# -> (# Word#, Word# #) + +foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter + +foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter + +foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr# + +foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# + +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable +getInfoTableOnStack stackSnapshot# index = + let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index)) + in peekItbl infoTablePtr + +getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable +getInfoTableForStack stackSnapshot# = + peekItbl $ + Ptr (getStackInfoTableAddr# stackSnapshot#) + +foreign import prim "getStackClosurezh" + getStackClosure# :: + StackSnapshot# -> Word# -> State# RealWorld -> (# State# RealWorld, Any #) + +foreign import prim "getStackFieldszh" + getStackFields# :: + StackSnapshot# -> (# Word32#, Word8#, Word8# #) + +getStackFields :: StackSnapshot# -> (Word32, Word8, Word8) +getStackFields stackSnapshot# = + case getStackFields# stackSnapshot# of + (# sSize#, sDirty#, sMarking# #) -> + (W32# sSize#, W8# sDirty#, W8# sMarking#) + +-- | `StackFrameLocation` of the top-most stack frame +stackHead :: StackSnapshot# -> StackFrameLocation +stackHead s# = (StackSnapshot s#, 0) -- GHC stacks are never empty + +-- | Advance to the next stack frame (if any) +-- +-- The last `Int#` in the result tuple is meant to be treated as bool +-- (has_next). +foreign import prim "advanceStackFrameLocationzh" + advanceStackFrameLocation# :: + StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #) + +-- | Advance to the next stack frame (if any) +advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation +advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) = + let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index) + in if I# hasNext > 0 + then Just (StackSnapshot s', primWordToWordOffset i') + else Nothing + where + primWordToWordOffset :: Word# -> WordOffset + primWordToWordOffset w# = fromIntegral (W# w#) + +getClosureBox :: StackSnapshot# -> WordOffset -> IO Box +getClosureBox stackSnapshot# index = + -- Beware! We have to put ptr into a Box immediately. Otherwise, the garbage + -- collector might move the referenced closure, without updating our reference + -- (pointer) to it. + IO $ \s -> + case getStackClosure# + stackSnapshot# + (wordOffsetToWord# index) + s of + (# s1, ptr #) -> + (# s1, Box ptr #) + +-- | Representation of @StgLargeBitmap@ (RTS) +data LargeBitmap = LargeBitmap + { largeBitmapSize :: Word, + largebitmapWords :: Ptr Word + } + +-- | Is a bitmap entry a closure pointer or a primitive non-pointer? +data Pointerness = Pointer | NonPointer + deriving (Show) + +decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField] +decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do + let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of + (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#) + bitmapWords <- largeBitmapToList largeBitmap + decodeBitmaps + stackSnapshot# + (index + relativePayloadOffset) + (bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords) + where + largeBitmapToList :: LargeBitmap -> IO [Word] + largeBitmapToList LargeBitmap {..} = + cWordArrayToList largebitmapWords $ + (usedBitmapWords . fromIntegral) largeBitmapSize + + cWordArrayToList :: Ptr Word -> Int -> IO [Word] + cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)] + + usedBitmapWords :: Int -> Int + usedBitmapWords 0 = error "Invalid large bitmap size 0." + usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1 + + bitmapWordsPointerness :: Word -> [Word] -> [Pointerness] + bitmapWordsPointerness size _ | size <= 0 = [] + bitmapWordsPointerness _ [] = [] + bitmapWordsPointerness size (w : wds) = + bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w + ++ bitmapWordsPointerness (size - fromIntegral wORD_SIZE_IN_BITS) wds + +bitmapWordPointerness :: Word -> Word -> [Pointerness] +bitmapWordPointerness 0 _ = [] +bitmapWordPointerness bSize bitmapWord = + ( if (bitmapWord .&. 1) /= 0 + then NonPointer + else Pointer + ) + : bitmapWordPointerness + (bSize - 1) + (bitmapWord `shiftR` 1) + +decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> IO [StackField] +decodeBitmaps stack# index ps = + zipWithM toPayload ps [index ..] + where + toPayload :: Pointerness -> WordOffset -> IO StackField + toPayload p i = case p of + NonPointer -> + pure $ StackWord (getWord stack# i) + Pointer -> StackBox <$> getClosureBox stack# i + +decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField] +decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = + let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of + (# b#, s# #) -> (W# b#, W# s#) + in decodeBitmaps + stackSnapshot# + (index + relativePayloadOffset) + (bitmapWordPointerness size bitmap) + +unpackStackFrame :: StackFrameLocation -> IO StackFrame +unpackStackFrame (StackSnapshot stackSnapshot#, index) = do + info <- getInfoTableOnStack stackSnapshot# index + unpackStackFrame' info + where + unpackStackFrame' :: StgInfoTable -> IO StackFrame + unpackStackFrame' info = + case tipe info of + RET_BCO -> do + bco' <- getClosureBox stackSnapshot# (index + offsetStgClosurePayload) + -- The arguments begin directly after the payload's one element + bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1) + pure + RetBCO + { info_tbl = info, + bco = bco', + bcoArgs = bcoArgs' + } + RET_SMALL -> do + payload' <- decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload + pure $ + RetSmall + { info_tbl = info, + stack_payload = payload' + } + RET_BIG -> do + payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload + pure $ + RetBig + { info_tbl = info, + stack_payload = payload' + } + RET_FUN -> do + let retFunType' = getRetFunType stackSnapshot# index + retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize) + retFunFun' <- getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun) + retFunPayload' <- + if retFunType' == ARG_GEN_BIG + then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload + else decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload + pure $ + RetFun + { info_tbl = info, + retFunType = retFunType', + retFunSize = retFunSize', + retFunFun = retFunFun', + retFunPayload = retFunPayload' + } + UPDATE_FRAME -> do + updatee' <- getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) + pure $ + UpdateFrame + { info_tbl = info, + updatee = updatee' + } + CATCH_FRAME -> do + let exceptions_blocked' = getWord stackSnapshot# (index + offsetStgCatchFrameExceptionsBlocked) + handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) + pure $ + CatchFrame + { info_tbl = info, + exceptions_blocked = exceptions_blocked', + handler = handler' + } + UNDERFLOW_FRAME -> do + let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index + stackClosure <- decodeStack nextChunk' + pure $ + UnderflowFrame + { info_tbl = info, + nextChunk = stackClosure + } + STOP_FRAME -> pure $ StopFrame {info_tbl = info} + ATOMICALLY_FRAME -> do + atomicallyFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) + result' <- getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) + pure $ + AtomicallyFrame + { info_tbl = info, + atomicallyFrameCode = atomicallyFrameCode', + result = result' + } + CATCH_RETRY_FRAME -> do + let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode) + first_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) + alt_code' <- getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) + pure $ + CatchRetryFrame + { info_tbl = info, + running_alt_code = running_alt_code', + first_code = first_code', + alt_code = alt_code' + } + CATCH_STM_FRAME -> do + catchFrameCode' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) + handler' <- getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) + pure $ + CatchStmFrame + { info_tbl = info, + catchFrameCode = catchFrameCode', + handler = handler' + } + x -> error $ "Unexpected closure type on stack: " ++ show x + +-- | Unbox 'Int#' from 'Int' +toInt# :: Int -> Int# +toInt# (I# i) = i + +-- | Convert `Int` to `Word#` +intToWord# :: Int -> Word# +intToWord# i = int2Word# (toInt# i) + +wordOffsetToWord# :: WordOffset -> Word# +wordOffsetToWord# wo = intToWord# (fromIntegral wo) + +-- | Location of a stackframe on the stack +-- +-- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom +-- of the stack. +type StackFrameLocation = (StackSnapshot, WordOffset) + +-- | Decode `StackSnapshot` to a `StgStackClosure` +-- +-- The return value is the representation of the @StgStack@ itself. +-- +-- See /Note [Decoding the stack]/. +decodeStack :: StackSnapshot -> IO StgStackClosure +decodeStack (StackSnapshot stack#) = do + info <- getInfoTableForStack stack# + case tipe info of + STACK -> do + let (stack_size', stack_dirty', stack_marking') = getStackFields stack# + sfls = stackFrameLocations stack# + stack' <- mapM unpackStackFrame sfls + pure $ + GenStgStackClosure + { ssc_info = info, + ssc_stack_size = stack_size', + ssc_stack_dirty = stack_dirty', + ssc_stack_marking = stack_marking', + ssc_stack = stack' + } + _ -> error $ "Expected STACK closure, got " ++ show info + where + stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] + stackFrameLocations s# = + stackHead s# + : go (advanceStackFrameLocation (stackHead s#)) + where + go :: Maybe StackFrameLocation -> [StackFrameLocation] + go Nothing = [] + go (Just r) = r : go (advanceStackFrameLocation r) + +#else +module GHC.Exts.Stack.Decode where +#endif ===================================== libraries/ghc-heap/cbits/Stack.c ===================================== @@ -0,0 +1,150 @@ +#include "MachDeps.h" +#include "Rts.h" +#include "RtsAPI.h" +#include "rts/Messages.h" +#include "rts/Types.h" +#include "rts/storage/ClosureTypes.h" +#include "rts/storage/Closures.h" +#include "rts/storage/InfoTables.h" + +StgWord stackFrameSize(StgStack *stack, StgWord index) { + StgClosure *c = (StgClosure *)stack->sp + index; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + return stack_frame_sizeW(c); +} + +StgStack *getUnderflowFrameStack(StgStack *stack, StgWord index) { + StgClosure *frame = (StgClosure *)stack->sp + index; + ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame)); + const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame); + + if (info->i.type == UNDERFLOW_FRAME) { + return ((StgUnderflowFrame *)frame)->next_chunk; + } else { + return NULL; + } +} + +// Only exists to make the get_itbl macro available in Haskell code (via FFI). +const StgInfoTable *getItbl(StgClosure *closure) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); + return get_itbl(closure); +}; + +StgWord getBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgWord bitmap = info->layout.bitmap; + return BITMAP_SIZE(bitmap); +} + +StgWord getRetFunBitmapSize(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_SIZE(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + return GET_FUN_LARGE_BITMAP(fun_info)->size; + default: + return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getBitmapWord(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgWord bitmap = info->layout.bitmap; + StgWord bitmapWord = BITMAP_BITS(bitmap); + return bitmapWord; +} + +StgWord getRetFunBitmapWord(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_BITS(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + // Cannot do more than warn and exit. + errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun); + stg_exit(EXIT_INTERNAL_ERROR); + default: + return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getLargeBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + const StgInfoTable *info = get_itbl(c); + StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info); + return bitmap->size; +} + +StgWord getRetFunSize(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + return BITMAP_SIZE(fun_info->f.b.bitmap); + case ARG_GEN_BIG: + return GET_FUN_LARGE_BITMAP(fun_info)->size; + default: + return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); + } +} + +StgWord getBCOLargeBitmapSize(StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + StgBCO *bco = (StgBCO *)*c->payload; + + return BCO_BITMAP_SIZE(bco); +} + +StgWord *getLargeBitmap(Capability *cap, StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + const StgInfoTable *info = get_itbl(c); + StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info); + + return bitmap->bitmap; +} + +StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info); + + return bitmap->bitmap; +} + +StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + StgBCO *bco = (StgBCO *)*c->payload; + StgLargeBitmap *bitmap = BCO_BITMAP(bco); + + return bitmap->bitmap; +} + +StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) { + return frame->next_chunk; +} + +StgWord getRetFunType(StgRetFun *ret_fun) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun)); + + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun)); + return fun_info->f.fun_type; +} + +StgClosure *getStackClosure(StgClosure **c) { return *c; } ===================================== libraries/ghc-heap/cbits/Stack.cmm ===================================== @@ -0,0 +1,187 @@ +// Uncomment to enable assertions during development +// #define DEBUG 1 + +#include "Cmm.h" + +// StgStack_marking was not available in the Stage0 compiler at the time of +// writing. Because, it has been added to derivedConstants when Stack.cmm was +// developed. +#if defined(StgStack_marking) + +// Returns the next stackframe's StgStack* and offset in it. And, an indicator +// if this frame is the last one (`hasNext` bit.) +// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords) +advanceStackFrameLocationzh (P_ stack, W_ offsetWords) { + W_ frameSize; + (frameSize) = ccall stackFrameSize(stack, offsetWords); + + P_ nextClosurePtr; + nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize)); + + P_ stackArrayPtr; + stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack; + + P_ stackBottom; + W_ stackSize, stackSizeInBytes; + stackSize = TO_W_(StgStack_stack_size(stack)); + stackSizeInBytes = WDS(stackSize); + stackBottom = stackSizeInBytes + stackArrayPtr; + + P_ newStack; + W_ newOffsetWords, hasNext; + if(nextClosurePtr < stackBottom) (likely: True) { + newStack = stack; + newOffsetWords = offsetWords + frameSize; + hasNext = 1; + } else { + P_ underflowFrameStack; + (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords); + if (underflowFrameStack == NULL) (likely: True) { + newStack = NULL; + newOffsetWords = NULL; + hasNext = NULL; + } else { + newStack = underflowFrameStack; + newOffsetWords = NULL; + hasNext = 1; + } + } + + return (newStack, newOffsetWords, hasNext); +} + +// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords) +getSmallBitmapzh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ bitmap, size; + (bitmap) = ccall getBitmapWord(c); + (size) = ccall getBitmapSize(c); + + return (bitmap, size); +} + + +// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords) +getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ bitmap, size, specialType; + (bitmap) = ccall getRetFunBitmapWord(c); + (size) = ccall getRetFunBitmapSize(c); + + return (bitmap, size); +} + +// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getLargeBitmap(MyCapability(), c); + (size) = ccall getLargeBitmapSize(c); + + return (words, size); +} + +// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getBCOLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getBCOLargeBitmap(MyCapability(), c); + (size) = ccall getBCOLargeBitmapSize(c); + + return (words, size); +} + +// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords) +getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) { + P_ c, words; + W_ size; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + (words) = ccall getRetFunLargeBitmap(MyCapability(), c); + (size) = ccall getRetFunSize(c); + + return (words, size); +} + +// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords) +getWordzh(P_ stack, W_ offsetWords) { + P_ wordAddr; + wordAddr = (StgStack_sp(stack) + WDS(offsetWords)); + return (W_[wordAddr]); +} + +// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords) +getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) { + P_ closurePtr; + closurePtr = (StgStack_sp(stack) + WDS(offsetWords)); + ASSERT(LOOKS_LIKE_CLOURE_PTR(closurePtr)); + + P_ next_chunk; + (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr); + ASSERT(LOOKS_LIKE_CLOURE_PTR(next_chunk)); + return (next_chunk); +} + +// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords) +getRetFunTypezh(P_ stack, W_ offsetWords) { + P_ c; + c = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(c)); + + W_ type; + (type) = ccall getRetFunType(c); + return (type); +} + +// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords) +getInfoTableAddrzh(P_ stack, W_ offsetWords) { + P_ p, info; + p = StgStack_sp(stack) + WDS(offsetWords); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(p)); + info = %GET_STD_INFO(UNTAG(p)); + + return (info); +} + +// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) +getStackInfoTableAddrzh(P_ stack) { + P_ info; + info = %GET_STD_INFO(UNTAG(stack)); + return (info); +} + +// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords) +getStackClosurezh(P_ stack, W_ offsetWords) { + P_ ptr; + ptr = StgStack_sp(stack) + WDS(offsetWords); + + P_ closure; + (closure) = ccall getStackClosure(ptr); + return (closure); +} + +// (bits32, bits8, bits8) getStackFieldszh(StgStack* stack) +getStackFieldszh(P_ stack){ + bits32 size; + bits8 dirty, marking; + + size = StgStack_stack_size(stack); + dirty = StgStack_dirty(stack); + marking = StgStack_marking(stack); + + return (size, dirty, marking); +} +#endif ===================================== libraries/ghc-heap/ghc-heap.cabal.in ===================================== @@ -30,6 +30,8 @@ library ghc-options: -Wall if !os(ghcjs) cmm-sources: cbits/HeapPrim.cmm + cbits/Stack.cmm + c-sources: cbits/Stack.c default-extensions: NoImplicitPrelude @@ -48,3 +50,6 @@ library GHC.Exts.Heap.ProfInfo.PeekProfInfo GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled + GHC.Exts.Stack.Constants + GHC.Exts.Stack + GHC.Exts.Stack.Decode ===================================== libraries/ghc-heap/tests/TestUtils.hs ===================================== @@ -1,7 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} -module TestUtils where +{-# LANGUAGE UnliftedFFITypes #-} -assertEqual :: (Show a, Eq a) => a -> a -> IO () +module TestUtils + ( assertEqual, + assertThat, + assertStackInvariants, + getDecodedStack, + unbox, + ) +where + +import Control.Monad.IO.Class +import Data.Array.Byte +import Data.Foldable +import Debug.Trace +import GHC.Exts +import GHC.Exts.Heap +import GHC.Exts.Heap.Closures +import GHC.Exts.Stack.Decode +import GHC.Records +import GHC.Stack (HasCallStack) +import GHC.Stack.CloneStack +import Unsafe.Coerce (unsafeCoerce) + +getDecodedStack :: IO (StackSnapshot, [StackFrame]) +getDecodedStack = do + stack <- cloneMyStack + stackClosure <- decodeStack stack + + pure (stack, ssc_stack stackClosure) + +assertEqual :: (HasCallStack, Monad m, Show a, Eq a) => a -> a -> m () assertEqual a b | a /= b = error (show a ++ " /= " ++ show b) - | otherwise = return () + | otherwise = pure () + +assertThat :: (HasCallStack, Monad m) => String -> (a -> Bool) -> a -> m () +assertThat s f a = if f a then pure () else error s + +assertStackInvariants :: (HasCallStack, MonadIO m) => [StackFrame] -> m () +assertStackInvariants decodedStack = + assertThat + "Last frame is stop frame" + ( \case + StopFrame info -> tipe info == STOP_FRAME + _ -> False + ) + (last decodedStack) + +unbox :: Box -> IO Closure +unbox = getBoxedClosureData ===================================== libraries/ghc-heap/tests/all.T ===================================== @@ -57,3 +57,48 @@ test('parse_tso_flags', test('T21622', only_ways(['normal']), compile_and_run, ['']) + +test('stack_big_ret', + [ + extra_files(['TestUtils.hs']), + ignore_stdout, + ignore_stderr + ], + compile_and_run, + ['']) + +# Options: +# - `-kc512B -kb64B`: Make stack chunk size small to provoke underflow +# stack frames. +test('stack_underflow', + [ + extra_files(['TestUtils.hs']), + extra_run_opts('+RTS -kc512B -kb64B -RTS'), + ignore_stdout, + ignore_stderr + ], + compile_and_run, + ['']) + +test('stack_stm_frames', + [ + extra_files(['TestUtils.hs']), + ignore_stdout, + ignore_stderr + ], + compile_and_run, + ['']) + +test('stack_misc_closures', + [ + extra_files(['stack_misc_closures_c.c', 'stack_misc_closures_prim.cmm', 'TestUtils.hs']), + ignore_stdout, + ignore_stderr + ], + multi_compile_and_run, + ['stack_misc_closures', + [ ('stack_misc_closures_c.c', '') + ,('stack_misc_closures_prim.cmm', '') + ] + , '-debug' # Debug RTS to use checkSTACK() (Sanity.c) + ]) ===================================== libraries/ghc-heap/tests/stack_big_ret.hs ===================================== @@ -0,0 +1,142 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import Control.Concurrent +import Data.IORef +import Data.Maybe +import GHC.Exts (StackSnapshot#) +import GHC.Exts.Heap +import GHC.Exts.Heap.ClosureTypes +import GHC.Exts.Heap.Closures +import GHC.Exts.Heap.InfoTable.Types +import GHC.Exts.Stack.Decode +import GHC.IO.Unsafe +import GHC.Stack (HasCallStack) +import GHC.Stack.CloneStack +import System.IO (hPutStrLn, stderr) +import System.Mem +import TestUtils + +cloneStackReturnInt :: IORef (Maybe StackSnapshot) -> Int +cloneStackReturnInt ioRef = unsafePerformIO $ do + stackSnapshot <- cloneMyStack + + writeIORef ioRef (Just stackSnapshot) + + pure 42 + +-- | Clone a stack with a RET_BIG closure and decode it. +main :: HasCallStack => IO () +main = do + stackRef <- newIORef Nothing + + bigFun (cloneStackReturnInt stackRef) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 + + mbStackSnapshot <- readIORef stackRef + let stackSnapshot = fromJust mbStackSnapshot + stackClosure <- decodeStack stackSnapshot + let stackFrames = ssc_stack stackClosure + + assertStackInvariants stackFrames + assertThat + "Stack contains one big return frame" + (== 1) + (length $ filter isBigReturnFrame stackFrames) + let cs = (stack_payload . head) $ filter isBigReturnFrame stackFrames + let xs = zip [1 ..] cs + mapM_ (uncurry checkArg) xs + +checkArg :: Word -> StackField -> IO () +checkArg w sf = + case sf of + StackWord _ -> error "Unexpected payload type from bitmap." + StackBox b -> do + c <- getBoxedClosureData b + assertEqual CONSTR_0_1 $ (tipe . info) c + assertEqual "I#" (name c) + assertEqual "ghc-prim" (pkg c) + assertEqual "GHC.Types" (modl c) + assertEqual True $ (null . ptrArgs) c + assertEqual [w] (dataArgs c) + pure () + +isBigReturnFrame :: StackFrame -> Bool +isBigReturnFrame (RetBig info _) = tipe info == RET_BIG +isBigReturnFrame _ = False + +{-# NOINLINE bigFun #-} +bigFun :: + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + Int -> + IO () +bigFun !a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47 a48 a49 a50 a51 a52 a53 a54 a55 a56 a57 a58 a59 a60 a61 a62 a63 a64 a65 = + do + print $ a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + a31 + a32 + a33 + a34 + a35 + a36 + a37 + a38 + a39 + a40 + a41 + a42 + a43 + a44 + a45 + a46 + a47 + a48 + a49 + a50 + a51 + a52 + a53 + a54 + a55 + a56 + a57 + a58 + a59 + a60 + a61 + a62 + a63 + a64 + a65 + + pure () ===================================== libraries/ghc-heap/tests/stack_misc_closures.hs ===================================== @@ -0,0 +1,526 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} +{-# LANGUAGE UnliftedFFITypes #-} + +module Main where + +import Data.Functor +import Debug.Trace +import GHC.Exts +import GHC.Exts.Heap +import GHC.Exts.Heap (getBoxedClosureData) +import GHC.Exts.Heap.Closures +import GHC.Exts.Heap.Closures (GenStackFrame (retFunFun), StackField) +import GHC.Exts.Stack +import GHC.Exts.Stack.Decode +import GHC.IO (IO (..)) +import GHC.Stack (HasCallStack) +import GHC.Stack.CloneStack (StackSnapshot (..)) +import System.Info +import System.Mem +import TestUtils +import Unsafe.Coerce (unsafeCoerce) + +foreign import prim "any_update_framezh" any_update_frame# :: SetupFunction + +foreign import prim "any_catch_framezh" any_catch_frame# :: SetupFunction + +foreign import prim "any_catch_stm_framezh" any_catch_stm_frame# :: SetupFunction + +foreign import prim "any_catch_retry_framezh" any_catch_retry_frame# :: SetupFunction + +foreign import prim "any_atomically_framezh" any_atomically_frame# :: SetupFunction + +foreign import prim "any_ret_small_prim_framezh" any_ret_small_prim_frame# :: SetupFunction + +foreign import prim "any_ret_small_prims_framezh" any_ret_small_prims_frame# :: SetupFunction + +foreign import prim "any_ret_small_closure_framezh" any_ret_small_closure_frame# :: SetupFunction + +foreign import prim "any_ret_small_closures_framezh" any_ret_small_closures_frame# :: SetupFunction + +foreign import prim "any_ret_big_prims_min_framezh" any_ret_big_prims_min_frame# :: SetupFunction + +foreign import prim "any_ret_big_closures_min_framezh" any_ret_big_closures_min_frame# :: SetupFunction + +foreign import prim "any_ret_big_closures_two_words_framezh" any_ret_big_closures_two_words_frame# :: SetupFunction + +foreign import prim "any_ret_fun_arg_n_prim_framezh" any_ret_fun_arg_n_prim_frame# :: SetupFunction + +foreign import prim "any_ret_fun_arg_gen_framezh" any_ret_fun_arg_gen_frame# :: SetupFunction + +foreign import prim "any_ret_fun_arg_gen_big_framezh" any_ret_fun_arg_gen_big_frame# :: SetupFunction + +foreign import prim "any_bco_framezh" any_bco_frame# :: SetupFunction + +foreign import prim "any_underflow_framezh" any_underflow_frame# :: SetupFunction + +foreign import ccall "maxSmallBitmapBits" maxSmallBitmapBits_c :: Word + +foreign import ccall "bitsInWord" bitsInWord :: Word + +{- Test stategy + ~~~~~~~~~~~~ + +- Create @StgStack at s in C that contain two frames: A stop frame and the frame +which's decoding should be tested. + +- Cmm primops are used to get `StackSnapshot#` values. (This detour ensures that +the closures are referenced by `StackSnapshot#` and not garbage collected right +away.) + +- These can then be decoded and checked. + +This strategy may look pretty complex for a test. But, it can provide very +specific corner cases that would be hard to (reliably!) produce in Haskell. + +N.B. `StackSnapshots` are managed by the garbage collector. It's important to +know that the GC may rewrite parts of the stack and that the stack must be sound +(otherwise, the GC may fail badly.) To find subtle garbage collection related +bugs, the GC is triggered several times. + +The decission to make `StackSnapshots`s (and their closures) being managed by the +GC isn't accidential. It's closer to the reality of decoding stacks. + +N.B. the test data stack are only meant be de decoded. They are not executable +(the result would likely be a crash or non-sense.) + +- Due to the implementation details of the test framework, the Debug.Trace calls +are only shown when the test fails. They are used as markers to see where the +test fails on e.g. a segfault (where the HasCallStack constraint isn't helpful.) +-} +main :: HasCallStack => IO () +main = do + traceM "Test 1" + test any_update_frame# $ + \case + UpdateFrame {..} -> do + assertEqual (tipe info_tbl) UPDATE_FRAME + assertEqual 1 =<< getWordFromBlackhole updatee + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 2" + testSize any_update_frame# 2 + traceM "Test 3" + test any_catch_frame# $ + \case + CatchFrame {..} -> do + assertEqual (tipe info_tbl) CATCH_FRAME + assertEqual exceptions_blocked 1 + assertConstrClosure 1 handler + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 4" + testSize any_catch_frame# 3 + traceM "Test 5" + test any_catch_stm_frame# $ + \case + CatchStmFrame {..} -> do + assertEqual (tipe info_tbl) CATCH_STM_FRAME + assertConstrClosure 1 catchFrameCode + assertConstrClosure 2 handler + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 6" + testSize any_catch_stm_frame# 3 + traceM "Test 7" + test any_catch_retry_frame# $ + \case + CatchRetryFrame {..} -> do + assertEqual (tipe info_tbl) CATCH_RETRY_FRAME + assertEqual running_alt_code 1 + assertConstrClosure 2 first_code + assertConstrClosure 3 alt_code + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 8" + testSize any_catch_retry_frame# 4 + traceM "Test 9" + test any_atomically_frame# $ + \case + AtomicallyFrame {..} -> do + assertEqual (tipe info_tbl) ATOMICALLY_FRAME + assertConstrClosure 1 atomicallyFrameCode + assertConstrClosure 2 result + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 10" + testSize any_atomically_frame# 3 + traceM "Test 11" + test any_ret_small_prim_frame# $ + \case + RetSmall {..} -> do + assertEqual (tipe info_tbl) RET_SMALL + assertEqual (length stack_payload) 1 + assertUnknownTypeWordSizedPrimitive 1 (head stack_payload) + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 12" + testSize any_ret_small_prim_frame# 2 + traceM "Test 13" + test any_ret_small_closure_frame# $ + \case + RetSmall {..} -> do + assertEqual (tipe info_tbl) RET_SMALL + assertEqual (length stack_payload) 1 + assertConstrClosure 1 $ (stackFieldClosure . head) stack_payload + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 14" + testSize any_ret_small_closure_frame# 2 + traceM "Test 15" + test any_ret_small_closures_frame# $ + \case + RetSmall {..} -> do + assertEqual (tipe info_tbl) RET_SMALL + assertEqual (length stack_payload) maxSmallBitmapBits + wds <- mapM (getWordFromConstr01 . stackFieldClosure) stack_payload + assertEqual wds [1 .. maxSmallBitmapBits] + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 16" + testSize any_ret_small_closures_frame# (1 + fromIntegral maxSmallBitmapBits_c) + traceM "Test 17" + test any_ret_small_prims_frame# $ + \case + RetSmall {..} -> do + assertEqual (tipe info_tbl) RET_SMALL + assertEqual (length stack_payload) maxSmallBitmapBits + let wds = map stackFieldWord stack_payload + assertEqual wds [1 .. maxSmallBitmapBits] + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 18" + testSize any_ret_small_prims_frame# (1 + fromIntegral maxSmallBitmapBits_c) + traceM "Test 19" + test any_ret_big_prims_min_frame# $ + \case + RetBig {..} -> do + assertEqual (tipe info_tbl) RET_BIG + assertEqual (length stack_payload) minBigBitmapBits + let wds = map stackFieldWord stack_payload + assertEqual wds [1 .. minBigBitmapBits] + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 20" + testSize any_ret_big_prims_min_frame# (minBigBitmapBits + 1) + traceM "Test 21" + test any_ret_big_closures_min_frame# $ + \case + RetBig {..} -> do + assertEqual (tipe info_tbl) RET_BIG + assertEqual (length stack_payload) minBigBitmapBits + wds <- mapM (getWordFromConstr01 . stackFieldClosure) stack_payload + assertEqual wds [1 .. minBigBitmapBits] + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 22" + testSize any_ret_big_closures_min_frame# (minBigBitmapBits + 1) + traceM "Test 23" + test any_ret_big_closures_two_words_frame# $ + \case + RetBig {..} -> do + assertEqual (tipe info_tbl) RET_BIG + let closureCount = fromIntegral $ bitsInWord + 1 + assertEqual (length stack_payload) closureCount + wds <- mapM (getWordFromConstr01 . stackFieldClosure) stack_payload + assertEqual wds [1 .. (fromIntegral closureCount)] + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 24" + testSize any_ret_big_closures_two_words_frame# (fromIntegral bitsInWord + 1 + 1) + traceM "Test 25" + test any_ret_fun_arg_n_prim_frame# $ + \case + RetFun {..} -> do + assertEqual (tipe info_tbl) RET_FUN + assertEqual retFunType ARG_N + assertEqual retFunSize 1 + assertFun01Closure 1 retFunFun + assertEqual (length retFunPayload) 1 + let wds = map stackFieldWord retFunPayload + assertEqual wds [1] + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 26" + test any_ret_fun_arg_gen_frame# $ + \case + RetFun {..} -> do + assertEqual (tipe info_tbl) RET_FUN + assertEqual retFunType ARG_GEN + assertEqual retFunSize 9 + retFunFun' <- getBoxedClosureData retFunFun + case retFunFun' of + FunClosure {..} -> do + assertEqual (tipe info) FUN_STATIC + assertEqual (null dataArgs) True + -- Darwin seems to have a slightly different layout regarding + -- function `argGenFun` + assertEqual (null ptrArgs) (os /= "darwin") + e -> error $ "Wrong closure type: " ++ show e + assertEqual (length retFunPayload) 9 + wds <- mapM (getWordFromConstr01 . stackFieldClosure) retFunPayload + assertEqual wds [1 .. 9] + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 27" + testSize any_ret_fun_arg_gen_frame# (3 + 9) + traceM "Test 28" + test any_ret_fun_arg_gen_big_frame# $ + \case + RetFun {..} -> do + assertEqual (tipe info_tbl) RET_FUN + assertEqual retFunType ARG_GEN_BIG + assertEqual retFunSize 59 + retFunFun' <- getBoxedClosureData retFunFun + case retFunFun' of + FunClosure {..} -> do + assertEqual (tipe info) FUN_STATIC + assertEqual (null dataArgs) True + assertEqual (null ptrArgs) True + e -> error $ "Wrong closure type: " ++ show e + assertEqual (length retFunPayload) 59 + wds <- mapM (getWordFromConstr01 . stackFieldClosure) retFunPayload + assertEqual wds [1 .. 59] + traceM "Test 29" + testSize any_ret_fun_arg_gen_big_frame# (3 + 59) + traceM "Test 30" + test any_bco_frame# $ + \case + RetBCO {..} -> do + assertEqual (tipe info_tbl) RET_BCO + assertEqual (length bcoArgs) 1 + wds <- mapM (getWordFromConstr01 . stackFieldClosure) bcoArgs + assertEqual wds [3] + bco' <- getBoxedClosureData bco + case bco' of + BCOClosure {..} -> do + assertEqual (tipe info) BCO + assertEqual arity 3 + assertEqual size 7 + assertArrWordsClosure [1] instrs + assertArrWordsClosure [2] literals + assertMutArrClosure [3] bcoptrs + assertEqual + [ 1, -- StgLargeBitmap size in words + 0 -- StgLargeBitmap first words + ] + bitmap + e -> error $ "Wrong closure type: " ++ show e + e -> error $ "Wrong closure type: " ++ show e + traceM "Test 31" + testSize any_bco_frame# 3 + traceM "Test 32" + test any_underflow_frame# $ + \case + UnderflowFrame {..} -> do + assertEqual (tipe info_tbl) UNDERFLOW_FRAME + assertEqual (tipe (ssc_info nextChunk)) STACK + assertEqual (ssc_stack_size nextChunk) 27 + assertEqual (ssc_stack_dirty nextChunk) 0 + assertEqual (ssc_stack_marking nextChunk) 0 + assertEqual (length (ssc_stack nextChunk)) 2 + case head (ssc_stack nextChunk) of + RetSmall {..} -> + assertEqual (tipe info_tbl) RET_SMALL + e -> error $ "Wrong closure type: " ++ show e + case last (ssc_stack nextChunk) of + StopFrame {..} -> + assertEqual (tipe info_tbl) STOP_FRAME + e -> error $ "Wrong closure type: " ++ show e + e -> error $ "Wrong closure type: " ++ show e + testSize any_underflow_frame# 2 + +type SetupFunction = State# RealWorld -> (# State# RealWorld, StackSnapshot# #) + +test :: HasCallStack => SetupFunction -> (StackFrame -> IO ()) -> IO () +test setup assertion = do + stackSnapshot <- getStackSnapshot setup + performGC + traceM $ "entertainGC - " ++ entertainGC 100 + -- Run garbage collection now, to prevent later surprises: It's hard to debug + -- when the GC suddenly does it's work and there were bad closures or pointers. + -- Better fail early, here. + performGC + stackClosure <- decodeStack stackSnapshot + performGC + let stack = ssc_stack stackClosure + performGC + assert stack + where + assert :: [StackFrame] -> IO () + assert stack = do + assertStackInvariants stack + assertEqual (length stack) 2 + assertion $ head stack + +entertainGC :: Int -> String +entertainGC 0 = "0" +entertainGC x = show x ++ entertainGC (x - 1) + +testSize :: HasCallStack => SetupFunction -> Int -> IO () +testSize setup expectedSize = do + stackSnapshot <- getStackSnapshot setup + stackClosure <- decodeStack stackSnapshot + assertEqual expectedSize $ (stackFrameSize . head . ssc_stack) stackClosure + +-- | Get a `StackSnapshot` from test setup +-- +-- This function mostly resembles `cloneStack`. Though, it doesn't clone, but +-- just pulls a @StgStack@ from RTS to Haskell land. +getStackSnapshot :: SetupFunction -> IO StackSnapshot +getStackSnapshot action# = IO $ \s -> + case action# s of (# s1, stack #) -> (# s1, StackSnapshot stack #) + +assertConstrClosure :: HasCallStack => Word -> Box -> IO () +assertConstrClosure w c = + getBoxedClosureData c >>= \case + ConstrClosure {..} -> do + assertEqual (tipe info) CONSTR_0_1 + assertEqual dataArgs [w] + assertEqual (null ptrArgs) True + e -> error $ "Wrong closure type: " ++ show e + +assertArrWordsClosure :: HasCallStack => [Word] -> Box -> IO () +assertArrWordsClosure wds c = + getBoxedClosureData c >>= \case + ArrWordsClosure {..} -> do + assertEqual (tipe info) ARR_WORDS + assertEqual arrWords wds + e -> error $ "Wrong closure type: " ++ show e + +assertMutArrClosure :: HasCallStack => [Word] -> Box -> IO () +assertMutArrClosure wds c = + getBoxedClosureData c >>= \case + MutArrClosure {..} -> do + assertEqual (tipe info) MUT_ARR_PTRS_FROZEN_CLEAN + assertEqual wds =<< mapM getWordFromConstr01 mccPayload + e -> error $ "Wrong closure type: " ++ show e + +assertFun01Closure :: HasCallStack => Word -> Box -> IO () +assertFun01Closure w c = + getBoxedClosureData c >>= \case + FunClosure {..} -> do + assertEqual (tipe info) FUN_0_1 + assertEqual dataArgs [w] + assertEqual (null ptrArgs) True + e -> error $ "Wrong closure type: " ++ show e + +getWordFromConstr01 :: HasCallStack => Box -> IO Word +getWordFromConstr01 c = + getBoxedClosureData c >>= \case + ConstrClosure {..} -> pure $ head dataArgs + e -> error $ "Wrong closure type: " ++ show e + +getWordFromBlackhole :: HasCallStack => Box -> IO Word +getWordFromBlackhole c = + getBoxedClosureData c >>= \case + BlackholeClosure {..} -> getWordFromConstr01 indirectee + -- For test stability reasons: Expect that the blackhole might have been + -- resolved. + ConstrClosure {..} -> pure $ head dataArgs + e -> error $ "Wrong closure type: " ++ show e + +assertUnknownTypeWordSizedPrimitive :: HasCallStack => Word -> StackField -> IO () +assertUnknownTypeWordSizedPrimitive w stackField = + assertEqual (stackFieldWord stackField) w + +unboxSingletonTuple :: (# StackSnapshot# #) -> StackSnapshot# +unboxSingletonTuple (# s# #) = s# + +minBigBitmapBits :: Num a => a +minBigBitmapBits = 1 + maxSmallBitmapBits + +maxSmallBitmapBits :: Num a => a +maxSmallBitmapBits = fromIntegral maxSmallBitmapBits_c + +stackFieldClosure :: HasCallStack => StackField -> Box +stackFieldClosure (StackBox b) = b +stackFieldClosure w = error $ "Expected closure in a Box, got: " ++ show w + +stackFieldWord :: HasCallStack => StackField -> Word +stackFieldWord (StackWord w) = w +stackFieldWord c = error $ "Expected word, got: " ++ show c + +-- | A function with 59 arguments +-- +-- A small bitmap has @64 - 6 = 58@ entries on 64bit machines. On 32bit machines +-- it's less (for obvious reasons.) I.e. this function's bitmap a large one; +-- function type is @ARG_GEN_BIG at . +{-# NOINLINE argGenBigFun #-} +argGenBigFun :: + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word +argGenBigFun a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32 a33 a34 a35 a36 a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47 a48 a49 a50 a51 a52 a53 a54 a55 a56 a57 a58 a59 = + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 + a26 + a27 + a28 + a29 + a30 + a31 + a32 + a33 + a34 + a35 + a36 + a37 + a38 + a39 + a40 + a41 + a42 + a43 + a44 + a45 + a46 + a47 + a48 + a49 + a50 + a51 + a52 + a53 + a54 + a55 + a56 + a57 + a58 + a59 + +-- | A function with more arguments than the pre-generated (@ARG_PPPPPPPP -> 8@) ones +-- have +-- +-- This results in a @ARG_GEN@ function (the number of arguments still fits in a +-- small bitmap). +{-# NOINLINE argGenFun #-} +argGenFun :: + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word -> + Word +argGenFun a1 a2 a3 a4 a5 a6 a7 a8 a9 = a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 ===================================== libraries/ghc-heap/tests/stack_misc_closures_c.c ===================================== @@ -0,0 +1,357 @@ +#include "Rts.h" + +// See rts/Threads.c +#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 3) + +// Copied from Cmm.h +#define SIZEOF_W SIZEOF_VOID_P +#define WDS(n) ((n)*SIZEOF_W) + +// Update frames are interpreted by the garbage collector. We play it some +// tricks here with a fake blackhole. +RTS_RET(test_fake_blackhole); +void create_any_update_frame(Capability *cap, StgStack *stack, StgWord w) { + StgUpdateFrame *updF = (StgUpdateFrame *)stack->sp; + SET_HDR(updF, &stg_upd_frame_info, CCS_SYSTEM); + // StgInd and a BLACKHOLE have the same structure + StgInd *blackhole = (StgInd *)allocate(cap, sizeofW(StgInd)); + SET_HDR(blackhole, &test_fake_blackhole_info, CCS_SYSTEM); + StgClosure *payload = rts_mkWord(cap, w); + blackhole->indirectee = payload; + updF->updatee = (StgClosure *)blackhole; +} + +void create_any_catch_frame(Capability *cap, StgStack *stack, StgWord w) { + StgCatchFrame *catchF = (StgCatchFrame *)stack->sp; + SET_HDR(catchF, &stg_catch_frame_info, CCS_SYSTEM); + StgClosure *payload = rts_mkWord(cap, w); + catchF->exceptions_blocked = 1; + catchF->handler = payload; +} + +void create_any_catch_stm_frame(Capability *cap, StgStack *stack, StgWord w) { + StgCatchSTMFrame *catchF = (StgCatchSTMFrame *)stack->sp; + SET_HDR(catchF, &stg_catch_stm_frame_info, CCS_SYSTEM); + StgClosure *payload1 = rts_mkWord(cap, w); + catchF->code = payload1; + StgClosure *payload2 = rts_mkWord(cap, w + 1); + catchF->handler = payload2; +} + +void create_any_catch_retry_frame(Capability *cap, StgStack *stack, StgWord w) { + StgCatchRetryFrame *catchRF = (StgCatchRetryFrame *)stack->sp; + SET_HDR(catchRF, &stg_catch_retry_frame_info, CCS_SYSTEM); + catchRF->running_alt_code = w++; + StgClosure *payload1 = rts_mkWord(cap, w++); + catchRF->first_code = payload1; + StgClosure *payload2 = rts_mkWord(cap, w); + catchRF->alt_code = payload2; +} + +void create_any_atomically_frame(Capability *cap, StgStack *stack, StgWord w) { + StgAtomicallyFrame *aF = (StgAtomicallyFrame *)stack->sp; + SET_HDR(aF, &stg_atomically_frame_info, CCS_SYSTEM); + StgClosure *payload1 = rts_mkWord(cap, w); + aF->code = payload1; + StgClosure *payload2 = rts_mkWord(cap, w + 1); + aF->result = payload2; +} + +void create_any_ret_small_prim_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgClosure *c = (StgClosure *)stack->sp; + SET_HDR(c, &stg_ret_n_info, CCS_SYSTEM); + // The cast is a lie (w is interpreted as plain Word, not as pointer), but the + // memory layout fits. + c->payload[0] = (StgClosure *)w; +} + +void create_any_ret_small_closure_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgClosure *c = (StgClosure *)stack->sp; + SET_HDR(c, &stg_ret_p_info, CCS_SYSTEM); + StgClosure *payload = rts_mkWord(cap, w); + c->payload[0] = payload; +} + +#define MAX_SMALL_BITMAP_BITS (BITS_IN(W_) - BITMAP_BITS_SHIFT) + +StgWord maxSmallBitmapBits() { return MAX_SMALL_BITMAP_BITS; } + +StgWord bitsInWord() { return BITS_IN(W_); } + +RTS_RET(test_small_ret_full_p); +void create_any_ret_small_closures_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgClosure *c = (StgClosure *)stack->sp; + SET_HDR(c, &test_small_ret_full_p_info, CCS_SYSTEM); + for (int i = 0; i < MAX_SMALL_BITMAP_BITS; i++) { + StgClosure *payload1 = UNTAG_CLOSURE(rts_mkWord(cap, w)); + w++; + c->payload[i] = payload1; + } +} + +RTS_RET(test_small_ret_full_n); +void create_any_ret_small_prims_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgClosure *c = (StgClosure *)stack->sp; + SET_HDR(c, &test_small_ret_full_n_info, CCS_SYSTEM); + for (int i = 0; i < MAX_SMALL_BITMAP_BITS; i++) { + c->payload[i] = (StgClosure *)w; + w++; + } +} + +#define MIN_LARGE_BITMAP_BITS (MAX_SMALL_BITMAP_BITS + 1) + +RTS_RET(test_big_ret_min_n); +void create_any_ret_big_prims_min_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgClosure *c = (StgClosure *)stack->sp; + SET_HDR(c, &test_big_ret_min_n_info, CCS_SYSTEM); + + for (int i = 0; i < MIN_LARGE_BITMAP_BITS; i++) { + c->payload[i] = (StgClosure *)w; + w++; + } +} + +RTS_RET(test_big_ret_min_p); +void create_any_ret_big_closures_min_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgClosure *c = (StgClosure *)stack->sp; + SET_HDR(c, &test_big_ret_min_p_info, CCS_SYSTEM); + + for (int i = 0; i < MIN_LARGE_BITMAP_BITS; i++) { + c->payload[i] = UNTAG_CLOSURE(rts_mkWord(cap, w)); + w++; + } +} + +#define TWO_WORDS_LARGE_BITMAP_BITS (BITS_IN(W_) + 1) + +RTS_RET(test_big_ret_two_words_p); +void create_any_ret_big_closures_two_words_frame(Capability *cap, + StgStack *stack, StgWord w) { + StgClosure *c = (StgClosure *)stack->sp; + SET_HDR(c, &test_big_ret_two_words_p_info, CCS_SYSTEM); + + for (int i = 0; i < TWO_WORDS_LARGE_BITMAP_BITS; i++) { + c->payload[i] = UNTAG_CLOSURE(rts_mkWord(cap, w)); + w++; + } +} + +RTS_RET(test_ret_fun); +RTS_RET(test_arg_n_fun_0_1); +void create_any_ret_fun_arg_n_prim_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgRetFun *c = (StgRetFun *)stack->sp; + c->info = &test_ret_fun_info; + StgClosure *f = + (StgClosure *)allocate(cap, sizeofW(StgClosure) + sizeofW(StgWord)); + SET_HDR(f, &test_arg_n_fun_0_1_info, ccs) + c->fun = f; + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun)); + c->size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); + // The cast is a lie (w is interpreted as plain Word, not as pointer), but the + // memory layout fits. + c->payload[0] = (StgClosure *)w; + f->payload[0] = (StgClosure *)w; +} + +RTS_CLOSURE(Main_argGenFun_closure); +void create_any_ret_fun_arg_gen_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgRetFun *c = (StgRetFun *)stack->sp; + c->info = &test_ret_fun_info; + c->fun = &Main_argGenFun_closure; + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun)); + c->size = BITMAP_SIZE(fun_info->f.b.bitmap); + for (int i = 0; i < c->size; i++) { + c->payload[i] = rts_mkWord(cap, w++); + } +} + +RTS_CLOSURE(Main_argGenBigFun_closure); +void create_any_ret_fun_arg_gen_big_frame(Capability *cap, StgStack *stack, + StgWord w) { + StgRetFun *c = (StgRetFun *)stack->sp; + c->info = &test_ret_fun_info; + c->fun = &Main_argGenBigFun_closure; + const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(c->fun)); + c->size = GET_FUN_LARGE_BITMAP(fun_info)->size; + for (int i = 0; i < c->size; i++) { + c->payload[i] = rts_mkWord(cap, w++); + } +} + +RTS_RET(test_ret_bco); +void create_any_bco_frame(Capability *cap, StgStack *stack, StgWord w) { + StgClosure *c = (StgClosure *)stack->sp; + SET_HDR(c, &test_ret_bco_info, CCS_SYSTEM); + StgWord bcoSizeWords = + sizeofW(StgBCO) + sizeofW(StgLargeBitmap) + sizeofW(StgWord); + StgBCO *bco = (StgBCO *)allocate(cap, bcoSizeWords); + SET_HDR(bco, &stg_BCO_info, CCS_MAIN); + c->payload[0] = (StgClosure *)bco; + + bco->size = bcoSizeWords; + bco->arity = 3; + + StgArrBytes *instrs = + (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + sizeofW(StgWord)); + SET_HDR(instrs, &stg_ARR_WORDS_info, CCCS); + instrs->bytes = WDS(1); + instrs->payload[0] = w++; + bco->instrs = instrs; + + StgArrBytes *literals = + (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + sizeofW(StgWord)); + SET_HDR(literals, &stg_ARR_WORDS_info, CCCS); + bco->literals = literals; + literals->bytes = WDS(1); + literals->payload[0] = w++; + bco->literals = literals; + + StgWord ptrsSize = 1 + mutArrPtrsCardTableSize(1); + StgMutArrPtrs *ptrs = + (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + ptrsSize); + SET_HDR(ptrs, &stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, ccs); + ptrs->ptrs = 1; + ptrs->size = ptrsSize; + ptrs->payload[0] = rts_mkWord(cap, w); + bco->ptrs = ptrs; + + StgLargeBitmap *bitmap = (StgLargeBitmap *)bco->bitmap; + bitmap->size = 1; + bitmap->bitmap[0] = 0; // set bit 0 to 0 indicating a closure + c->payload[1] = (StgClosure *)rts_mkWord(cap, w); +} + +StgStack *any_ret_small_prim_frame(Capability *cap); + +void create_any_underflow_frame(Capability *cap, StgStack *stack, StgWord w) { + StgUnderflowFrame *underflowF = (StgUnderflowFrame *)stack->sp; + underflowF->info = &stg_stack_underflow_frame_info; + underflowF->next_chunk = any_ret_small_prim_frame(cap); +} + +// Import from Sanity.c - This implies that the test must be run with debug RTS +// only! +extern void checkSTACK(StgStack *stack); + +// Basically, a stripped down version of createThread() (regarding stack +// creation) +StgStack *setup(Capability *cap, StgWord closureSizeWords, + void (*f)(Capability *, StgStack *, StgWord)) { + StgWord totalSizeWords = + sizeofW(StgStack) + closureSizeWords + MIN_STACK_WORDS; + StgStack *stack = (StgStack *)allocate(cap, totalSizeWords); + SET_HDR(stack, &stg_STACK_info, CCS_SYSTEM); + stack->stack_size = totalSizeWords - sizeofW(StgStack); + stack->dirty = 0; + stack->marking = 0; + + StgPtr spBottom = stack->stack + stack->stack_size; + stack->sp = spBottom; + stack->sp -= sizeofW(StgStopFrame); + SET_HDR((StgClosure *)stack->sp, &stg_stop_thread_info, CCS_SYSTEM); + stack->sp -= closureSizeWords; + + // Pointers can easíly be confused with each other. Provide a start value for + // values (1) in closures and increment it after every usage. The goal is to + // have distinct values in the closure to ensure nothing gets mixed up. + f(cap, stack, 1); + + // Make a sanitiy check to find unsound closures before the GC and the decode + // code. + checkSTACK(stack); + return stack; +} + +StgStack *any_update_frame(Capability *cap) { + return setup(cap, sizeofW(StgUpdateFrame), &create_any_update_frame); +} + +StgStack *any_catch_frame(Capability *cap) { + return setup(cap, sizeofW(StgCatchFrame), &create_any_catch_frame); +} + +StgStack *any_catch_stm_frame(Capability *cap) { + return setup(cap, sizeofW(StgCatchSTMFrame), &create_any_catch_stm_frame); +} + +StgStack *any_catch_retry_frame(Capability *cap) { + return setup(cap, sizeofW(StgCatchRetryFrame), &create_any_catch_retry_frame); +} + +StgStack *any_atomically_frame(Capability *cap) { + return setup(cap, sizeofW(StgAtomicallyFrame), &create_any_atomically_frame); +} + +StgStack *any_ret_small_prim_frame(Capability *cap) { + return setup(cap, sizeofW(StgClosure) + sizeofW(StgWord), + &create_any_ret_small_prim_frame); +} + +StgStack *any_ret_small_closure_frame(Capability *cap) { + return setup(cap, sizeofW(StgClosure) + sizeofW(StgClosurePtr), + &create_any_ret_small_closure_frame); +} + +StgStack *any_ret_small_closures_frame(Capability *cap) { + return setup( + cap, sizeofW(StgClosure) + MAX_SMALL_BITMAP_BITS * sizeofW(StgClosurePtr), + &create_any_ret_small_closures_frame); +} + +StgStack *any_ret_small_prims_frame(Capability *cap) { + return setup(cap, + sizeofW(StgClosure) + MAX_SMALL_BITMAP_BITS * sizeofW(StgWord), + &create_any_ret_small_prims_frame); +} + +StgStack *any_ret_big_closures_min_frame(Capability *cap) { + return setup( + cap, sizeofW(StgClosure) + MIN_LARGE_BITMAP_BITS * sizeofW(StgClosure), + &create_any_ret_big_closures_min_frame); +} + +StgStack *any_ret_big_closures_two_words_frame(Capability *cap) { + return setup(cap, + sizeofW(StgClosure) + + TWO_WORDS_LARGE_BITMAP_BITS * sizeofW(StgClosure), + &create_any_ret_big_closures_two_words_frame); +} + +StgStack *any_ret_big_prims_min_frame(Capability *cap) { + return setup(cap, + sizeofW(StgClosure) + MIN_LARGE_BITMAP_BITS * sizeofW(StgWord), + &create_any_ret_big_prims_min_frame); +} + +StgStack *any_ret_fun_arg_n_prim_frame(Capability *cap) { + return setup(cap, sizeofW(StgRetFun) + sizeofW(StgWord), + &create_any_ret_fun_arg_n_prim_frame); +} + +StgStack *any_ret_fun_arg_gen_frame(Capability *cap) { + return setup(cap, sizeofW(StgRetFun) + 9 * sizeofW(StgClosure), + &create_any_ret_fun_arg_gen_frame); +} + +StgStack *any_ret_fun_arg_gen_big_frame(Capability *cap) { + return setup(cap, sizeofW(StgRetFun) + 59 * sizeofW(StgWord), + &create_any_ret_fun_arg_gen_big_frame); +} + +StgStack *any_bco_frame(Capability *cap) { + return setup(cap, sizeofW(StgClosure) + 2 * sizeofW(StgWord), + &create_any_bco_frame); +} + +StgStack *any_underflow_frame(Capability *cap) { + return setup(cap, sizeofW(StgUnderflowFrame), &create_any_underflow_frame); +} ===================================== libraries/ghc-heap/tests/stack_misc_closures_prim.cmm ===================================== @@ -0,0 +1,231 @@ +#include "Cmm.h" + +any_update_framezh() { + P_ stack; + (stack) = ccall any_update_frame(MyCapability() "ptr"); + return (stack); +} + +any_catch_framezh() { + P_ stack; + (stack) = ccall any_catch_frame(MyCapability() "ptr"); + return (stack); +} + +any_catch_stm_framezh() { + P_ stack; + (stack) = ccall any_catch_stm_frame(MyCapability() "ptr"); + return (stack); +} + +any_catch_retry_framezh() { + P_ stack; + (stack) = ccall any_catch_retry_frame(MyCapability() "ptr"); + return (stack); +} + +any_atomically_framezh() { + P_ stack; + (stack) = ccall any_atomically_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_small_prim_framezh() { + P_ stack; + (stack) = ccall any_ret_small_prim_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_small_prims_framezh() { + P_ stack; + (stack) = ccall any_ret_small_prims_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_small_closure_framezh() { + P_ stack; + (stack) = ccall any_ret_small_closure_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_small_closures_framezh() { + P_ stack; + (stack) = ccall any_ret_small_closures_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_big_prims_min_framezh() { + P_ stack; + (stack) = ccall any_ret_big_prims_min_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_big_closures_min_framezh() { + P_ stack; + (stack) = ccall any_ret_big_closures_min_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_big_closures_two_words_framezh() { + P_ stack; + (stack) = ccall any_ret_big_closures_two_words_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_fun_arg_n_prim_framezh() { + P_ stack; + (stack) = ccall any_ret_fun_arg_n_prim_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_fun_arg_gen_framezh() { + P_ stack; + (stack) = ccall any_ret_fun_arg_gen_frame(MyCapability() "ptr"); + return (stack); +} + +any_ret_fun_arg_gen_big_framezh() { + P_ stack; + (stack) = ccall any_ret_fun_arg_gen_big_frame(MyCapability() "ptr"); + return (stack); +} + +any_bco_framezh() { + P_ stack; + (stack) = ccall any_bco_frame(MyCapability() "ptr"); + return (stack); +} + +any_underflow_framezh() { + P_ stack; + (stack) = ccall any_underflow_frame(MyCapability() "ptr"); + return (stack); +} + +INFO_TABLE_RET ( test_small_ret_full_p, RET_SMALL, W_ info_ptr, +#if SIZEOF_VOID_P == 4 +P_ ptr1, P_ ptr2, P_ ptr3, P_ ptr4, P_ ptr5, P_ ptr6, P_ ptr7, P_ ptr8, P_ ptr9, P_ ptr10, +P_ ptr11, P_ ptr12, P_ ptr13, P_ ptr14, P_ ptr15, P_ ptr16, P_ ptr17, P_ ptr18, P_ ptr19, P_ ptr20, +P_ ptr21, P_ ptr22, P_ ptr23, P_ ptr24, P_ ptr25, P_ ptr26, P_ ptr27 +) +#elif SIZEOF_VOID_P == 8 +P_ ptr1, P_ ptr2, P_ ptr3, P_ ptr4, P_ ptr5, P_ ptr6, P_ ptr7, P_ ptr8, P_ ptr9, P_ ptr10, +P_ ptr11, P_ ptr12, P_ ptr13, P_ ptr14, P_ ptr15, P_ ptr16, P_ ptr17, P_ ptr18, P_ ptr19, P_ ptr20, +P_ ptr21, P_ ptr22, P_ ptr23, P_ ptr24, P_ ptr25, P_ ptr26, P_ ptr27, P_ ptr28, P_ ptr29, P_ ptr30, +P_ ptr31, P_ ptr32, P_ ptr33, P_ ptr34, P_ ptr35, P_ ptr36, P_ ptr37, P_ ptr38, P_ ptr39, P_ ptr40, +P_ ptr41, P_ ptr42, P_ ptr43, P_ ptr44, P_ ptr45, P_ ptr46, P_ ptr47, P_ ptr48, P_ ptr49, P_ ptr50, +P_ ptr51, P_ ptr52, P_ ptr53, P_ ptr54, P_ ptr55, P_ ptr56, P_ ptr57, P_ ptr58 +) +#endif + return (/* no return values */) +{ + return (); +} + +INFO_TABLE_RET ( test_small_ret_full_n, RET_SMALL, W_ info_ptr, +#if SIZEOF_VOID_P == 4 +W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10, +W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20, +W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27 +) +#elif SIZEOF_VOID_P == 8 +W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10, +W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20, +W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27, W_ n28, W_ n29, W_ n30, +W_ n31, W_ n32, W_ n33, W_ n34, W_ n35, W_ n36, W_ n37, W_ n38, W_ n39, W_ n40, +W_ n41, W_ n42, W_ n43, W_ n44, W_ n45, W_ n46, W_ n47, W_ n48, W_ n49, W_ n50, +W_ n51, W_ n52, W_ n53, W_ n54, W_ n55, W_ n56, W_ n57, W_ n58 +) +#endif + return (/* no return values */) +{ + return (); +} + +// Size of this large bitmap closure is: max size of small bitmap + 1 +INFO_TABLE_RET ( test_big_ret_min_n, RET_BIG, W_ info_ptr, +#if SIZEOF_VOID_P == 4 +W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10, +W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20, +W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27, W_ n28 +#elif SIZEOF_VOID_P == 8 +W_ n1, W_ n2, W_ n3, W_ n4, W_ n5, W_ n6, W_ n7, W_ n8, W_ n9, W_ n10, +W_ n11, W_ n12, W_ n13, W_ n14, W_ n15, W_ n16, W_ n17, W_ n18, W_ n19, W_ n20, +W_ n21, W_ n22, W_ n23, W_ n24, W_ n25, W_ n26, W_ n27, W_ n28, W_ n29, W_ n30, +W_ n31, W_ n32, W_ n33, W_ n34, W_ n35, W_ n36, W_ n37, W_ n38, W_ n39, W_ n40, +W_ n41, W_ n42, W_ n43, W_ n44, W_ n45, W_ n46, W_ n47, W_ n48, W_ n49, W_ n50, +W_ n51, W_ n52, W_ n53, W_ n54, W_ n55, W_ n56, W_ n57, W_ n58, W_ n59 +#endif +) + return (/* no return values */) +{ + return (); +} + +// Size of this large bitmap closure is: max size of small bitmap + 1 +INFO_TABLE_RET ( test_big_ret_min_p, RET_BIG, W_ info_ptr, +#if SIZEOF_VOID_P == 4 +P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10, +P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20, +P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28 +#elif SIZEOF_VOID_P == 8 +P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10, +P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20, +P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30, +P_ p31, P_ p32, P_ p33, P_ p34, P_ p35, P_ p36, P_ p37, P_ p38, P_ p39, P_ p40, +P_ p41, P_ p42, P_ p43, P_ p44, P_ p45, P_ p46, P_ p47, P_ p48, P_ p49, P_ p50, +P_ p51, P_ p52, P_ p53, P_ p54, P_ p55, P_ p56, P_ p57, P_ p58, P_ p59 +#endif +) + return (/* no return values */) +{ + return (); +} + +// Size of this large bitmap closure is: max size of bits in machine word + 1. +// This results in a two word StgLargeBitmap. +INFO_TABLE_RET ( test_big_ret_two_words_p, RET_BIG, W_ info_ptr, +#if SIZEOF_VOID_P == 4 +P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10, +P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20, +P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30, +P_ p31, P_ p32, P_ p33 +#elif SIZEOF_VOID_P == 8 +P_ p1, P_ p2, P_ p3, P_ p4, P_ p5, P_ p6, P_ p7, P_ p8, P_ p9, P_ p10, +P_ p11, P_ p12, P_ p13, P_ p14, P_ p15, P_ p16, P_ p17, P_ p18, P_ p19, P_ p20, +P_ p21, P_ p22, P_ p23, P_ p24, P_ p25, P_ p26, P_ p27, P_ p28, P_ p29, P_ p30, +P_ p31, P_ p32, P_ p33, P_ p34, P_ p35, P_ p36, P_ p37, P_ p38, P_ p39, P_ p40, +P_ p41, P_ p42, P_ p43, P_ p44, P_ p45, P_ p46, P_ p47, P_ p48, P_ p49, P_ p50, +P_ p51, P_ p52, P_ p53, P_ p54, P_ p55, P_ p56, P_ p57, P_ p58, P_ p59, P_ p60, +P_ p61, P_ p62, P_ p63, P_ p64, P_ p65 +#endif +) + return (/* no return values */) +{ + return (); +} + +// A BLACKHOLE without any code. Just a placeholder to keep the GC happy. +INFO_TABLE( test_fake_blackhole, 1, 0, BLACKHOLE, "BLACKHOLE", "BLACKHOLE") + (P_ node) +{ + return (); +} + +INFO_TABLE_RET ( test_ret_fun, RET_FUN, W_ info_ptr, W_ size, P_ fun, P_ payload) + return (/* no return values */) +{ + return (); +} + +INFO_TABLE_FUN ( test_arg_n_fun_0_1, 0 , 0, FUN_0_1, "FUN_0_1", "FUN_0_1", 1, ARG_N) + return (/* no return values */) +{ + return (); +} + +INFO_TABLE_RET( test_ret_bco, RET_BCO) + return (/* no return values */) +{ + return (); +} ===================================== libraries/ghc-heap/tests/stack_stm_frames.hs ===================================== @@ -0,0 +1,38 @@ +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Control.Concurrent.STM +import Control.Exception +import GHC.Conc +import GHC.Exts.Heap +import GHC.Exts.Heap.ClosureTypes +import GHC.Exts.Heap.Closures +import GHC.Exts.Heap.InfoTable.Types +import GHC.Exts.Stack.Decode +import GHC.Stack.CloneStack +import TestUtils + +main :: IO () +main = do + (stackSnapshot, decodedStack) <- + atomically $ + catchSTM @SomeException (unsafeIOToSTM getDecodedStack) throwSTM + + assertStackInvariants decodedStack + assertThat + "Stack contains one catch stm frame" + (== 1) + (length $ filter isCatchStmFrame decodedStack) + assertThat + "Stack contains one atomically frame" + (== 1) + (length $ filter isAtomicallyFrame decodedStack) + +isCatchStmFrame :: StackFrame -> Bool +isCatchStmFrame (CatchStmFrame {..}) = tipe info_tbl == CATCH_STM_FRAME +isCatchStmFrame _ = False + +isAtomicallyFrame :: StackFrame -> Bool +isAtomicallyFrame (AtomicallyFrame {..}) = tipe info_tbl == ATOMICALLY_FRAME +isAtomicallyFrame _ = False ===================================== libraries/ghc-heap/tests/stack_underflow.hs ===================================== @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Control.Monad +import Data.Bool (Bool (True)) +import GHC.Exts.Heap +import GHC.Exts.Heap.ClosureTypes +import GHC.Exts.Heap.Closures +import GHC.Exts.Heap.InfoTable.Types +import GHC.Exts.Stack.Decode +import GHC.Stack (HasCallStack) +import GHC.Stack.CloneStack +import TestUtils + +main = loop 256 + +{-# NOINLINE loop #-} +loop 0 = Control.Monad.void getStack +loop n = print "x" >> loop (n - 1) >> print "x" + +getStack :: HasCallStack => IO () +getStack = do + (s, decodedStack) <- getDecodedStack + assertStackInvariants decodedStack + assertThat + "Stack contains underflow frames" + (== True) + (any isUnderflowFrame decodedStack) + assertStackChunksAreDecodable decodedStack + return () + +isUnderflowFrame :: StackFrame -> Bool +isUnderflowFrame (UnderflowFrame {..}) = tipe info_tbl == UNDERFLOW_FRAME +isUnderflowFrame _ = False + +assertStackChunksAreDecodable :: HasCallStack => [StackFrame] -> IO () +assertStackChunksAreDecodable s = do + let underflowFrames = filter isUnderflowFrame s + assertThat + ("Expect some underflow frames. Got " ++ show (length underflowFrames)) + (>= 2) + (length underflowFrames) + let stackFrames = map (ssc_stack . nextChunk) underflowFrames + assertThat + "No empty stack chunks" + (== True) + ( not (any null stackFrames) + ) ===================================== rts/Printer.c ===================================== @@ -259,79 +259,79 @@ printClosure( const StgClosure *obj ) case UPDATE_FRAME: { - StgUpdateFrame* u = (StgUpdateFrame*)obj; + StgUpdateFrame* frame = (StgUpdateFrame*)obj; debugBelch("%s(", info_update_frame(obj)); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); debugBelch(","); - printPtr((StgPtr)u->updatee); + printPtr((StgPtr)frame->updatee); debugBelch(")\n"); break; } case CATCH_FRAME: { - StgCatchFrame* u = (StgCatchFrame*)obj; + StgCatchFrame* frame = (StgCatchFrame*)obj; debugBelch("CATCH_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); debugBelch(","); - printPtr((StgPtr)u->handler); + printPtr((StgPtr)frame->handler); debugBelch(")\n"); break; } case UNDERFLOW_FRAME: { - StgUnderflowFrame* u = (StgUnderflowFrame*)obj; + StgUnderflowFrame* frame = (StgUnderflowFrame*)obj; debugBelch("UNDERFLOW_FRAME("); - printPtr((StgPtr)u->next_chunk); + printPtr((StgPtr)frame->next_chunk); debugBelch(")\n"); break; } case STOP_FRAME: { - StgStopFrame* u = (StgStopFrame*)obj; + StgStopFrame* frame = (StgStopFrame*)obj; debugBelch("STOP_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); debugBelch(")\n"); break; } case ATOMICALLY_FRAME: { - StgAtomicallyFrame* u = (StgAtomicallyFrame*)obj; + StgAtomicallyFrame* frame = (StgAtomicallyFrame*)obj; debugBelch("ATOMICALLY_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); debugBelch(","); - printPtr((StgPtr)u->code); + printPtr((StgPtr)frame->code); debugBelch(","); - printPtr((StgPtr)u->result); + printPtr((StgPtr)frame->result); debugBelch(")\n"); break; } case CATCH_RETRY_FRAME: { - StgCatchRetryFrame* u = (StgCatchRetryFrame*)obj; + StgCatchRetryFrame* frame = (StgCatchRetryFrame*)obj; debugBelch("CATCH_RETRY_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); debugBelch(","); - printPtr((StgPtr)u->first_code); + printPtr((StgPtr)frame->first_code); debugBelch(","); - printPtr((StgPtr)u->alt_code); + printPtr((StgPtr)frame->alt_code); debugBelch(")\n"); break; } case CATCH_STM_FRAME: { - StgCatchSTMFrame* u = (StgCatchSTMFrame*)obj; + StgCatchSTMFrame* frame = (StgCatchSTMFrame*)obj; debugBelch("CATCH_STM_FRAME("); - printPtr((StgPtr)GET_INFO((StgClosure *)u)); + printPtr((StgPtr)GET_INFO((StgClosure *)frame)); debugBelch(","); - printPtr((StgPtr)u->code); + printPtr((StgPtr)frame->code); debugBelch(","); - printPtr((StgPtr)u->handler); + printPtr((StgPtr)frame->handler); debugBelch(")\n"); break; } @@ -715,17 +715,17 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type); switch (fun_info->f.fun_type) { case ARG_GEN: - printSmallBitmap(spBottom, sp+2, + printSmallBitmap(spBottom, (StgPtr) &ret_fun->payload, BITMAP_BITS(fun_info->f.b.bitmap), BITMAP_SIZE(fun_info->f.b.bitmap)); break; case ARG_GEN_BIG: - printLargeBitmap(spBottom, sp+2, + printLargeBitmap(spBottom, (StgPtr) &ret_fun->payload, GET_FUN_LARGE_BITMAP(fun_info), GET_FUN_LARGE_BITMAP(fun_info)->size); break; default: - printSmallBitmap(spBottom, sp+2, + printSmallBitmap(spBottom, (StgPtr) &ret_fun->payload, BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]), BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type])); break; ===================================== rts/include/rts/storage/InfoTables.h ===================================== @@ -122,7 +122,7 @@ extern const StgWord16 closure_flags[]; /* * A large bitmap. */ -typedef struct { +typedef struct StgLargeBitmap_ { StgWord size; StgWord bitmap[]; } StgLargeBitmap; ===================================== rts/sm/Sanity.c ===================================== @@ -42,7 +42,6 @@ int isHeapAlloced ( StgPtr p); static void checkSmallBitmap ( StgPtr payload, StgWord bitmap, uint32_t ); static void checkLargeBitmap ( StgPtr payload, StgLargeBitmap*, uint32_t ); static void checkClosureShallow ( const StgClosure * ); -static void checkSTACK (StgStack *stack); static void checkCompactObjects (bdescr *bd); @@ -725,7 +724,7 @@ checkCompactObjects(bdescr *bd) } } -static void +void checkSTACK (StgStack *stack) { StgPtr sp = stack->sp; @@ -1341,5 +1340,4 @@ memInventory (bool show) } - #endif /* DEBUG */ ===================================== rts/sm/Sanity.h ===================================== @@ -39,6 +39,7 @@ void memInventory (bool show); void checkBQ (StgTSO *bqe, StgClosure *closure); +void checkSTACK (StgStack *stack); #include "EndPrivate.h" #endif /* DEBUG */ ===================================== utils/deriveConstants/Main.hs ===================================== @@ -475,6 +475,7 @@ wanteds os = concat ,closureFieldOffset Both "StgStack" "stack" ,closureField C "StgStack" "stack_size" ,closureField C "StgStack" "dirty" + ,closureField C "StgStack" "marking" ,structSize C "StgTSOProfInfo" @@ -483,6 +484,11 @@ wanteds os = concat ,closureField C "StgCatchFrame" "handler" ,closureField C "StgCatchFrame" "exceptions_blocked" + ,structSize C "StgRetFun" + ,fieldOffset C "StgRetFun" "size" + ,fieldOffset C "StgRetFun" "fun" + ,fieldOffset C "StgRetFun" "payload" + ,closureSize C "StgPAP" ,closureField C "StgPAP" "n_args" ,closureFieldGcptr C "StgPAP" "fun" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a661ec564e5bab4c0cadb1af9ba2566b9b610df3...e778d8320606726a820f7f351b87f94e0f5a9888 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a661ec564e5bab4c0cadb1af9ba2566b9b610df3...e778d8320606726a820f7f351b87f94e0f5a9888 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 18:40:35 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 14:40:35 -0400 Subject: [Git][ghc/ghc][wip/romes/target-has-rts-linker] Move "target has RTS linker" out of settings Message-ID: <6459422358216_38ffda5c8c2e70521925@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/target-has-rts-linker at Glasgow Haskell Compiler / GHC Commits: d81375a9 by Rodrigo Mesquita at 2023-05-08T19:38:32+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Note that previously we would consider `powerpc`s and `s390x`s other than `powerpc-ibm-aix*` and `s390x-ibm-linux` to have an RTS linker, but the RTS linker supports neither platform. Closes #23361 - - - - - 10 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/Platform.hs - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -4727,8 +4727,9 @@ compilerInfo dflags ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), - ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), + ("Have native code generator", showBool $ platformNcgSupported platform), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make at . ===================================== compiler/GHC/Platform.hs ===================================== @@ -271,6 +271,20 @@ platformCConvNeedsExtension platform = case platformArch platform of | OSDarwin <- platformOS platform -> True _ -> False +-- | Does this platform have an RTS linker? +platformHasRTSLinker :: Platform -> Bool +platformHasRTSLinker p = case archOS_arch (platformArchOS p) of + ArchPPC -> False -- powerpc + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False + ArchRISCV64 -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + ArchWasm32 -> False + _ -> True + + -------------------------------------------------- -- Instruction sets ===================================== configure.ac ===================================== @@ -330,18 +330,6 @@ if test x"$TablesNextToCode" = xYES; then fi AC_SUBST(TablesNextToCode) -dnl ** Does target have runtime linker support? -dnl -------------------------------------------------------------- -case "$target" in - powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) - TargetHasRTSLinker=NO - ;; - *) - TargetHasRTSLinker=YES - ;; -esac -AC_SUBST(TargetHasRTSLinker) - # Requires FPTOOLS_SET_PLATFORMS_VARS to be run first. FP_FIND_ROOT ===================================== distrib/configure.ac.in ===================================== @@ -20,9 +20,6 @@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ -TargetHasRTSLinker=@TargetHasRTSLinker@ -AC_SUBST(TargetHasRTSLinker) - TargetHasLibm=@TargetHasLibm@ AC_SUBST(TargetHasLibm) ===================================== hadrian/bindist/Makefile ===================================== @@ -116,7 +116,6 @@ lib/settings : config.mk @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ - @echo ',("target has RTS linker", "$(TargetHasRTSLinker)")' >> $@ @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ @echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -253,7 +253,6 @@ TargetWordBigEndian = @TargetWordBigEndian@ TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ TargetHasIdentDirective = @TargetHasIdentDirective@ TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -173,7 +173,6 @@ target-word-big-endian = @TargetWordBigEndian@ target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@ target-has-ident-directive = @TargetHasIdentDirective@ target-has-subsections-via-symbols = @TargetHasSubsectionsViaSymbols@ -target-has-rts-linker = @TargetHasRTSLinker@ target-has-libm = @TargetHasLibm@ target-arm-version = @ARM_ISA@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -79,7 +79,6 @@ data Setting = BuildArch | TargetOsHaskell | TargetArmVersion | TargetWordSize - | TargetHasRtsLinker | BourneShell -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). @@ -181,7 +180,6 @@ setting key = lookupSystemConfig $ case key of TargetArchHaskell -> "target-arch-haskell" TargetOsHaskell -> "target-os-haskell" TargetWordSize -> "target-word-size" - TargetHasRtsLinker -> "target-has-rts-linker" BourneShell -> "bourne-shell" bootIsStage0 :: Stage -> Stage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -451,7 +451,6 @@ generateSettings = do , ("target has GNU nonexec stack", expr $ lookupSystemConfig "target-has-gnu-nonexec-stack") , ("target has .ident directive", expr $ lookupSystemConfig "target-has-ident-directive") , ("target has subsections via symbols", expr $ lookupSystemConfig "target-has-subsections-via-symbols") - , ("target has RTS linker", expr $ lookupSystemConfig "target-has-rts-linker") , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) , ("LLVM target", getSetting LlvmTarget) ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -126,7 +126,9 @@ inTreeCompilerArgs stg = do libdir <- System.FilePath.normalise . (top -/-) <$> stageLibPath stg - rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker + -- For this information, we can only either query either ghc --info, or the + -- test settings (which indirectly queried ghc --info) + rtsLinker <- getBooleanSetting TestGhcWithRtsLinker return TestCompilerArgs{..} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d81375a902bf1b7fb0c88c729a065c5b1881797c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d81375a902bf1b7fb0c88c729a065c5b1881797c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 18:53:55 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Mon, 08 May 2023 14:53:55 -0400 Subject: [Git][ghc/ghc][wip/romes/target-has-rts-linker] Move "target has RTS linker" out of settings Message-ID: <645945439c359_38ffda5e198f08536990@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/target-has-rts-linker at Glasgow Haskell Compiler / GHC Commits: 66a4b0c5 by Rodrigo Mesquita at 2023-05-08T19:53:46+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Note that previously we would consider `powerpc`s and `s390x`s other than `powerpc-ibm-aix*` and `s390x-ibm-linux` to have an RTS linker, but the RTS linker supports neither platform. Closes #23361 - - - - - 10 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/Platform.hs - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -4727,8 +4727,9 @@ compilerInfo dflags ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), - ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), + ("Have native code generator", showBool $ platformNcgSupported platform), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make at . ===================================== compiler/GHC/Platform.hs ===================================== @@ -29,6 +29,7 @@ module GHC.Platform , platformInIntRange , platformInWordRange , platformCConvNeedsExtension + , platformHasRTSLinker , PlatformMisc(..) , SseVersion (..) , BmiVersion (..) @@ -271,6 +272,20 @@ platformCConvNeedsExtension platform = case platformArch platform of | OSDarwin <- platformOS platform -> True _ -> False +-- | Does this platform have an RTS linker? +platformHasRTSLinker :: Platform -> Bool +platformHasRTSLinker p = case archOS_arch (platformArchOS p) of + ArchPPC -> False -- powerpc + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False + ArchRISCV64 -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + ArchWasm32 -> False + _ -> True + + -------------------------------------------------- -- Instruction sets ===================================== configure.ac ===================================== @@ -330,18 +330,6 @@ if test x"$TablesNextToCode" = xYES; then fi AC_SUBST(TablesNextToCode) -dnl ** Does target have runtime linker support? -dnl -------------------------------------------------------------- -case "$target" in - powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) - TargetHasRTSLinker=NO - ;; - *) - TargetHasRTSLinker=YES - ;; -esac -AC_SUBST(TargetHasRTSLinker) - # Requires FPTOOLS_SET_PLATFORMS_VARS to be run first. FP_FIND_ROOT ===================================== distrib/configure.ac.in ===================================== @@ -20,9 +20,6 @@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ -TargetHasRTSLinker=@TargetHasRTSLinker@ -AC_SUBST(TargetHasRTSLinker) - TargetHasLibm=@TargetHasLibm@ AC_SUBST(TargetHasLibm) ===================================== hadrian/bindist/Makefile ===================================== @@ -116,7 +116,6 @@ lib/settings : config.mk @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ - @echo ',("target has RTS linker", "$(TargetHasRTSLinker)")' >> $@ @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ @echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -253,7 +253,6 @@ TargetWordBigEndian = @TargetWordBigEndian@ TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ TargetHasIdentDirective = @TargetHasIdentDirective@ TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -173,7 +173,6 @@ target-word-big-endian = @TargetWordBigEndian@ target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@ target-has-ident-directive = @TargetHasIdentDirective@ target-has-subsections-via-symbols = @TargetHasSubsectionsViaSymbols@ -target-has-rts-linker = @TargetHasRTSLinker@ target-has-libm = @TargetHasLibm@ target-arm-version = @ARM_ISA@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -79,7 +79,6 @@ data Setting = BuildArch | TargetOsHaskell | TargetArmVersion | TargetWordSize - | TargetHasRtsLinker | BourneShell -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). @@ -181,7 +180,6 @@ setting key = lookupSystemConfig $ case key of TargetArchHaskell -> "target-arch-haskell" TargetOsHaskell -> "target-os-haskell" TargetWordSize -> "target-word-size" - TargetHasRtsLinker -> "target-has-rts-linker" BourneShell -> "bourne-shell" bootIsStage0 :: Stage -> Stage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -451,7 +451,6 @@ generateSettings = do , ("target has GNU nonexec stack", expr $ lookupSystemConfig "target-has-gnu-nonexec-stack") , ("target has .ident directive", expr $ lookupSystemConfig "target-has-ident-directive") , ("target has subsections via symbols", expr $ lookupSystemConfig "target-has-subsections-via-symbols") - , ("target has RTS linker", expr $ lookupSystemConfig "target-has-rts-linker") , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) , ("LLVM target", getSetting LlvmTarget) ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -126,7 +126,9 @@ inTreeCompilerArgs stg = do libdir <- System.FilePath.normalise . (top -/-) <$> stageLibPath stg - rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker + -- For this information, we can only either query either ghc --info, or the + -- test settings (which indirectly queried ghc --info) + rtsLinker <- getBooleanSetting TestGhcWithRtsLinker return TestCompilerArgs{..} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66a4b0c5c160658042f542f962a3d10d3644a40b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66a4b0c5c160658042f542f962a3d10d3644a40b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 19:00:39 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 08 May 2023 15:00:39 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: docs: Remove mentions of ArrayArray# from unlifted FFI section Message-ID: <645946d72d381_38ffda5ed1d388539734@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 3e3a6be4 by Ben Gamari at 2023-05-08T12:15:19+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 888e9b81 by Torsten Schmits at 2023-05-08T15:00:24-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 28 changed files: - compiler/GHC/Driver/Flags.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - docs/users_guide/exts/ffi.rst - docs/users_guide/using-warnings.rst - rts/RtsStartup.c - testsuite/tests/mdo/should_compile/mdo002.hs - testsuite/tests/polykinds/MonoidsFD.hs - testsuite/tests/polykinds/MonoidsTF.hs - testsuite/tests/profiling/should_run/T3001-2.hs - testsuite/tests/profiling/should_run/ioprof.hs - testsuite/tests/rebindable/rebindable2.hs - testsuite/tests/rebindable/rebindable2.stdout - testsuite/tests/simplCore/T9646/StrictPrim.hs - testsuite/tests/simplCore/should_run/T17744A.hs - testsuite/tests/simplCore/should_run/T3591.hs - testsuite/tests/typecheck/should_run/T1735_Help/State.hs - testsuite/tests/typecheck/should_run/T4809_IdentityT.hs - testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs - testsuite/tests/wcompat-warnings/Template.hs - testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr Changes: ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -929,6 +929,7 @@ minusWcompatOpts :: [WarningFlag] minusWcompatOpts = [ Opt_WarnSemigroup , Opt_WarnNonCanonicalMonoidInstances + , Opt_WarnNonCanonicalMonadInstances , Opt_WarnCompatUnqualifiedImports , Opt_WarnTypeEqualityOutOfScope ] ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -65,6 +65,8 @@ interfaceErrorHints = \ case missingInterfaceErrorHints err Can'tFindNameInInterface {} -> noHints + CircularImport {} -> + noHints missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] missingInterfaceErrorHints = \case @@ -86,6 +88,8 @@ interfaceErrorReason (Can'tFindInterface err _) = missingInterfaceErrorReason err interfaceErrorReason (Can'tFindNameInInterface {}) = ErrorWithoutFlag +interfaceErrorReason (CircularImport {}) + = ErrorWithoutFlag missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason missingInterfaceErrorReason = \ case @@ -287,6 +291,9 @@ interfaceErrorDiagnostic opts = \ case LookingForSig sig -> hang (text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon) 2 (missingInterfaceErrorDiagnostic opts err) + CircularImport mod -> + text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc readInterfaceErrorDiagnostic = \ case ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -45,6 +45,7 @@ data IfaceMessage | Can'tFindNameInInterface Name [TyThing] -- possibly relevant TyThings + | CircularImport !Module deriving Generic data MissingInterfaceError ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -605,7 +605,7 @@ tcHiBootIface hsc_src mod (LookingForHiBoot mod) in failWithTc (TcRnInterfaceError diag) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) + NotBoot -> failWithTc (TcRnInterfaceError (CircularImport mod)) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} @@ -613,11 +613,6 @@ tcHiBootIface hsc_src mod need = text "Need the hi-boot interface for" <+> ppr mod <+> text "to compare against the Real Thing" - moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) - <+> text "depends on itself" - - - mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo mkSelfBootInfo iface mds = do -- NB: This is computed DIRECTLY from the ModIface rather ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -22,7 +22,6 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) import GHC.Hs -import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Rename.HsType @@ -452,11 +451,9 @@ checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () checkCanonicalInstances cls poly_ty mbinds = do whenWOptM Opt_WarnNonCanonicalMonadInstances $ checkCanonicalMonadInstances - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" whenWOptM Opt_WarnNonCanonicalMonoidInstances $ checkCanonicalMonoidInstances - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" where -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance @@ -472,19 +469,17 @@ checkCanonicalInstances cls poly_ty mbinds = do -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). -- - checkCanonicalMonadInstances refURL + checkCanonicalMonadInstances | cls == applicativeClassName = forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonadInstances "pure" "return" + -> addWarnNonCanonicalMonad NonCanonical_Pure | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" + -> addWarnNonCanonicalMonad NonCanonical_ThenA _ -> return () @@ -494,12 +489,10 @@ checkCanonicalInstances cls poly_ty mbinds = do FunBind { fun_id = L _ name , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonadInstances "return" "pure" + -> addWarnNonCanonicalMonad NonCanonical_Return | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" + -> addWarnNonCanonicalMonad NonCanonical_ThenM _ -> return () @@ -518,15 +511,14 @@ checkCanonicalInstances cls poly_ty mbinds = do -- -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). -- - checkCanonicalMonoidInstances refURL + checkCanonicalMonoidInstances | cls == semigroupClassName = forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" + -> addWarnNonCanonicalMonoid NonCanonical_Sappend _ -> return () @@ -536,9 +528,7 @@ checkCanonicalInstances cls poly_ty mbinds = do FunBind { fun_id = L _ name , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonoidInstances - "mappend" "(<>)" + -> addWarnNonCanonicalMonoid NonCanonical_Mappend _ -> return () @@ -554,51 +544,14 @@ checkCanonicalInstances cls poly_ty mbinds = do , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing - -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 refURL flag lhs rhs = do - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints $ - vcat [ text "Noncanonical" <+> - quotes (text (lhs ++ " = " ++ rhs)) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Move definition from" <+> - quotes (text rhs) <+> - text "to" <+> quotes (text lhs) - , text "See also:" <+> - text refURL - ] - addDiagnostic dia - - -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 refURL flag lhs rhs = do - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints $ - vcat [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , quotes (text lhs) <+> - text "will eventually be removed in favour of" <+> - quotes (text rhs) - , text "Either remove definition for" <+> - quotes (text lhs) <+> text "(recommended)" <+> - text "or define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - , text "See also:" <+> - text refURL - ] - addDiagnostic dia - - -- stolen from GHC.Tc.TyCl.Instance - instDeclCtxt1 :: LHsSigType GhcRn -> SDoc - instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - - inst_decl_ctxt :: SDoc -> SDoc - inst_decl_ctxt doc = hang (text "in the instance declaration for") - 2 (quotes doc <> text ".") + addWarnNonCanonicalMonoid reason = + addWarnNonCanonicalDefinition (NonCanonicalMonoid reason) + addWarnNonCanonicalMonad reason = + addWarnNonCanonicalDefinition (NonCanonicalMonad reason) + + addWarnNonCanonicalDefinition reason = + addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty) rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -1859,6 +1859,9 @@ instance Diagnostic TcRnMessage where locations = text "Bound at:" <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs))) + TcRnNonCanonicalDefinition reason inst_ty + -> mkSimpleDecorated $ + pprNonCanonicalDefinition inst_ty reason diagnosticReason = \case TcRnUnknownMessage m @@ -2484,6 +2487,11 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnBindingNameConflict{} -> ErrorWithoutFlag + TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _ + -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances + TcRnNonCanonicalDefinition (NonCanonicalMonad _) _ + -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances + diagnosticHints = \case TcRnUnknownMessage m @@ -3145,6 +3153,8 @@ instance Diagnostic TcRnMessage where -> noHints TcRnBindingNameConflict{} -> noHints + TcRnNonCanonicalDefinition reason _ + -> suggestNonCanonicalDefinition reason diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode diagnosticCode = constructorCode @@ -5451,3 +5461,78 @@ pprAmbiguousGreName gre | otherwise = pprPanic "addNameClassErrRn" (ppr gre) -- Invariant: either 'lcl' is True or 'iss' is non-empty + +pprNonCanonicalDefinition :: LHsSigType GhcRn + -> NonCanonicalDefinition + -> SDoc +pprNonCanonicalDefinition inst_ty = \case + NonCanonicalMonoid sub -> case sub of + NonCanonical_Sappend -> + msg1 "(<>)" "mappend" + NonCanonical_Mappend -> + msg2 "mappend" "(<>)" + NonCanonicalMonad sub -> case sub of + NonCanonical_Pure -> + msg1 "pure" "return" + NonCanonical_ThenA -> + msg1 "(*>)" "(>>)" + NonCanonical_Return -> + msg2 "return" "pure" + NonCanonical_ThenM -> + msg2 "(>>)" "(*>)" + where + msg1 :: String -> String -> SDoc + msg1 lhs rhs = + vcat [ text "Noncanonical" <+> + quotes (text (lhs ++ " = " ++ rhs)) <+> + text "definition detected" + , inst + ] + + msg2 :: String -> String -> SDoc + msg2 lhs rhs = + vcat [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , inst + , quotes (text lhs) <+> + text "will eventually be removed in favour of" <+> + quotes (text rhs) + ] + + inst = instDeclCtxt1 inst_ty + + -- stolen from GHC.Tc.TyCl.Instance + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc + instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + + inst_decl_ctxt :: SDoc -> SDoc + inst_decl_ctxt doc = hang (text "in the instance declaration for") + 2 (quotes doc <> text ".") + +suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint] +suggestNonCanonicalDefinition reason = + [action doc] + where + action = case reason of + NonCanonicalMonoid sub -> case sub of + NonCanonical_Sappend -> move sappendName mappendName + NonCanonical_Mappend -> remove mappendName sappendName + NonCanonicalMonad sub -> case sub of + NonCanonical_Pure -> move pureAName returnMName + NonCanonical_ThenA -> move thenAName thenMName + NonCanonical_Return -> remove returnMName pureAName + NonCanonical_ThenM -> remove thenMName thenAName + + move = SuggestMoveNonCanonicalDefinition + remove = SuggestRemoveNonCanonicalDefinition + + doc = case reason of + NonCanonicalMonoid _ -> doc_monoid + NonCanonicalMonad _ -> doc_monad + + doc_monoid = + "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" + doc_monad = + "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -116,6 +116,9 @@ module GHC.Tc.Errors.Types ( , UnusedImportName (..) , NestedForallsContextsIn(..) , UnusedNameProv(..) + , NonCanonicalDefinition(..) + , NonCanonical_Monoid(..) + , NonCanonical_Monad(..) ) where import GHC.Prelude @@ -4037,6 +4040,19 @@ data TcRnMessage where -- ^ The locations of the duplicates -> TcRnMessage + {-| TcRnNonCanonicalDefinition is a warning indicating that an instance + defines an implementation for a method that should not be defined in a way + that deviates from its default implementation, for example because it has + been scheduled to be absorbed into another method, like @pure@ making + @return@ obsolete. + + Test cases: + WCompatWarningsOn, WCompatWarningsOff, WCompatWarningsOnOff + -} + TcRnNonCanonicalDefinition :: !NonCanonicalDefinition -- ^ Specifics + -> !(LHsSigType GhcRn) -- ^ The instance type + -> TcRnMessage + deriving Generic -- | Things forbidden in @type data@ declarations. @@ -5567,3 +5583,34 @@ data UnusedNameProv | UnusedNameTypePattern | UnusedNameMatch | UnusedNameLocalBind + +-- | Different reasons for TcRnNonCanonicalDefinition. +data NonCanonicalDefinition = + -- | Related to @(<>)@ and @mappend at . + NonCanonicalMonoid NonCanonical_Monoid + | + -- | Related to @(*>)@/@(>>)@ and @pure@/@return at . + NonCanonicalMonad NonCanonical_Monad + deriving (Generic) + +-- | Possible cases for the -Wnoncanonical-monoid-instances. +data NonCanonical_Monoid = + -- | @(<>) = mappend@ was defined. + NonCanonical_Sappend + | + -- | @mappend@ was defined as something other than @(<>)@. + NonCanonical_Mappend + +-- | Possible cases for the -Wnoncanonical-monad-instances. +data NonCanonical_Monad = + -- | @pure = return@ was defined. + NonCanonical_Pure + | + -- | @(*>) = (>>)@ was defined. + NonCanonical_ThenA + | + -- | @return@ was defined as something other than @pure at . + NonCanonical_Return + | + -- | @(>>)@ was defined as something other than @(*>)@. + NonCanonical_ThenM ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -598,6 +598,8 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnIllegalInferredTyVars" = 54832 GhcDiagnosticCode "TcRnAmbiguousName" = 87543 GhcDiagnosticCode "TcRnBindingNameConflict" = 10498 + GhcDiagnosticCode "NonCanonicalMonoid" = 50928 + GhcDiagnosticCode "NonCanonicalMonad" = 22705 -- PatSynInvalidRhsReason GhcDiagnosticCode "PatSynNotInvertible" = 69317 @@ -717,6 +719,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "NoUnitIdMatching" = 51294 GhcDiagnosticCode "NotAModule" = 35235 GhcDiagnosticCode "Can'tFindNameInInterface" = 83249 + GhcDiagnosticCode "CircularImport" = 75429 GhcDiagnosticCode "HiModuleNameMismatchWarn" = 53693 GhcDiagnosticCode "ExceptionOccurred" = 47808 @@ -856,6 +859,7 @@ type family ConRecursInto con where ConRecursInto "DodgyImportsHiding" = 'Just ImportLookupReason ConRecursInto "TcRnImportLookup" = 'Just ImportLookupReason ConRecursInto "TcRnUnusedImport" = 'Just UnusedImportReason + ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition -- -- TH errors ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -438,6 +438,21 @@ data GhcHint bind anything useful. -} | SuggestRemoveRecordWildcard + {-| Suggest moving a method implementation to a different instance to its + superclass that defines the canonical version of the method. + -} + | SuggestMoveNonCanonicalDefinition + Name -- ^ move the implementation from this method + Name -- ^ ... to this method + String -- ^ Documentation URL + + {-| Suggest removing a method implementation when a superclass defines the + canonical version of that method. + -} + | SuggestRemoveNonCanonicalDefinition + Name -- ^ method with non-canonical implementation + Name -- ^ possible other method to use as the RHS instead + String -- ^ Documentation URL -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -234,6 +234,17 @@ instance Outputable GhcHint where -> text "Enable Safe Haskell through either Safe, Trustworthy or Unsafe." SuggestRemoveRecordWildcard -> text "Omit the" <+> quotes (text "..") + SuggestMoveNonCanonicalDefinition lhs rhs refURL -> + text "Move definition from" <+> + quotes (pprPrefixUnqual rhs) <+> + text "to" <+> quotes (pprPrefixUnqual lhs) $$ + text "See also:" <+> text refURL + SuggestRemoveNonCanonicalDefinition lhs rhs refURL -> + text "Either remove definition for" <+> + quotes (pprPrefixUnqual lhs) <+> text "(recommended)" <+> + text "or define as" <+> + quotes (pprPrefixUnqual lhs <+> text "=" <+> pprPrefixUnqual rhs) $$ + text "See also:" <+> text refURL perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" @@ -343,3 +354,7 @@ pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope) pp_ns rdr | ns /= tried_ns = pprNameSpace ns | otherwise = empty where ns = rdrNameSpace rdr + +pprPrefixUnqual :: Name -> SDoc +pprPrefixUnqual name = + pprPrefixOcc (getOccName name) ===================================== docs/users_guide/exts/ffi.rst ===================================== @@ -126,7 +126,7 @@ types may be used as arguments to FFI calls, subject to these restrictions: * Valid arguments for ``foreign import unsafe`` FFI calls: ``Array#``, - ``SmallArray#``, ``ArrayArray#``, ``ByteArray#``, and the mutable + ``SmallArray#``, ``ByteArray#``, and the mutable counterparts of these types. * Valid arguments for ``foreign import safe`` FFI calls: ``ByteArray#`` and ``MutableByteArray#``. The byte array must be @@ -174,10 +174,6 @@ are: +--------------------------------+-----------+-------------+-----------+---------------+ | ``MutableSmallArray#`` | Unsound | Unsound | Sound | Unsound | +--------------------------------+-----------+-------------+-----------+---------------+ - | ``ArrayArray#`` | Unsound | Unsound | Sound | Unsound | - +--------------------------------+-----------+-------------+-----------+---------------+ - | ``MutableArrayArray#`` | Unsound | Unsound | Sound | Unsound | - +--------------------------------+-----------+-------------+-----------+---------------+ | unpinned ``ByteArray#`` | Unsound | Unsound | Sound | Unsound | +--------------------------------+-----------+-------------+-----------+---------------+ | unpinned ``MutableByteArray#`` | Unsound | Unsound | Sound | Sound | @@ -210,32 +206,32 @@ anything from ``Rts.h``:: In other situations, the C function may need knowledge of the RTS closure types. The following example sums the first element of each ``ByteArray#`` (interpreting the bytes as an array of ``CInt``) -element of an ``ArrayArray##`` [3]_:: +element of an ``Array# ByteArray#`` [3]_:: // C source, must include the RTS to make the struct StgArrBytes - // available along with its fields: ptrs and payload. + // available along with its fields, such as `payload`. #include "Rts.h" - int sum_first (StgArrBytes **bufs) { - StgArrBytes **bufs = (StgArrBytes**)bufsTmp; + int sum_first (StgArrBytes **bufs, StgWord sz) { int res = 0; - for(StgWord ix = 0;ix < arr->ptrs;ix++) { + for(StgWord ix = 0; ix < sz; ix++) { res = res + ((int*)(bufs[ix]->payload))[0]; } return res; } - -- Haskell source, all elements in the argument array must be - -- either ByteArray# or MutableByteArray#. This is not enforced - -- by the type system in this example since ArrayArray is untyped. + -- Haskell source foreign import ccall unsafe "sum_first" - sumFirst :: ArrayArray# -> IO CInt + sumFirst :: Array# ByteArray# -> CInt -> IO CInt + + sumFirst' :: Array# ByteArray# -> IO CInt + sumFirst' arr = sumFirst arr (sizeofArray# arr) -Although GHC allows the user to pass all unlifted boxed types to -foreign functions, some of them are not amenable to useful work. -Although ``Array#`` is unlifted, the elements in its payload are -lifted, and a foreign C function cannot safely force thunks. Consequently, -a foreign C function may not dereference any of the addresses that comprise -the payload of the ``Array#``. +Although GHC allows the user to pass all unlifted boxed types to foreign +functions, some of them are not amenable to useful work. Although ``Array#`` +is unlifted, the elements in its payload can be lifted, and a foreign C +function cannot safely force thunks. Consequently, a foreign C function may not +dereference any of the addresses that comprise the payload of ``Array# a`` if +``a`` has a lifted representation. .. _ffi-newtype-io: @@ -1136,4 +1132,5 @@ byte array can be pinned as a result of three possible causes: as reading bytes from a ``MutableByteArray#``. Users should prefer ``GHC.Exts.readWord8Array#`` for this. .. [3] As in [2]_, the FFI is not actually needed for this. ``GHC.Exts`` - includes primitives for reading from on ``ArrayArray#``. + includes primitives for reading from an ``Array# a``, such as + ``GHC.Exts.indexArray#``. ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -163,6 +163,7 @@ as ``-Wno-...`` for every individual warning in the group. * :ghc-flag:`-Wsemigroup` * :ghc-flag:`-Wnoncanonical-monoid-instances` + * :ghc-flag:`-Wnoncanonical-monad-instances` * :ghc-flag:`-Wcompat-unqualified-imports` * :ghc-flag:`-Wtype-equality-out-of-scope` @@ -566,7 +567,7 @@ of ``-W(no-)*``. :since: 8.0 - :default: off + :default: on Warn if noncanonical ``Applicative`` or ``Monad`` instances declarations are detected. @@ -584,6 +585,8 @@ of ``-W(no-)*``. * Warn if ``pure`` is defined backwards (i.e. ``pure = return``). * Warn if ``(*>)`` is defined backwards (i.e. ``(*>) = (>>)``). + This warning is part of the :ghc-flag:`-Wcompat` option group. + .. ghc-flag:: -Wnoncanonical-monadfail-instances :shortdesc: *(deprecated)* warn when ``Monad`` or ``MonadFail`` instances have @@ -610,6 +613,8 @@ of ``-W(no-)*``. :since: 8.0 + :default: on + Warn if noncanonical ``Semigroup`` or ``Monoid`` instances declarations are detected. @@ -625,8 +630,7 @@ of ``-W(no-)*``. * Warn if ``(<>)`` is defined backwards (i.e. ``(<>) = mappend``). - This warning is off by default. However, it is part of the - :ghc-flag:`-Wcompat` option group. + This warning is part of the :ghc-flag:`-Wcompat` option group. .. ghc-flag:: -Wmissing-monadfail-instances :shortdesc: *(deprecated)* ===================================== rts/RtsStartup.c ===================================== @@ -68,7 +68,7 @@ #endif // Count of how many outstanding hs_init()s there have been. -static int hs_init_count = 0; +static StgWord hs_init_count = 0; static bool rts_shutdown = false; #if defined(mingw32_HOST_OS) @@ -242,8 +242,9 @@ hs_init_with_rtsopts(int *argc, char **argv[]) void hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) { - hs_init_count++; - if (hs_init_count > 1) { + // N.B. atomic_inc returns the new value. + StgWord init_count = atomic_inc(&hs_init_count, 1); + if (init_count > 1) { // second and subsequent inits are ignored return; } @@ -452,15 +453,17 @@ hs_exit_(bool wait_foreign) { uint32_t g, i; - if (hs_init_count <= 0) { - errorBelch("warning: too many hs_exit()s"); + // N.B. atomic_dec returns the new value. + StgInt init_count = (StgInt)atomic_dec(&hs_init_count); + if (init_count > 0) { + // ignore until it's the last one return; } - hs_init_count--; - if (hs_init_count > 0) { - // ignore until it's the last one + if (init_count < 0) { + errorBelch("warning: too many hs_exit()s"); return; } + rts_shutdown = true; /* start timing the shutdown */ ===================================== testsuite/tests/mdo/should_compile/mdo002.hs ===================================== @@ -13,11 +13,10 @@ instance Functor X where fmap f (X a) = X (f a) instance Applicative X where - pure = return + pure = X (<*>) = ap instance Monad X where - return = X (X a) >>= f = f a instance MonadFix X where ===================================== testsuite/tests/polykinds/MonoidsFD.hs ===================================== @@ -25,7 +25,7 @@ class Monoidy to comp id m | m to → comp id where -- We use functional dependencies to help the typechecker understand that -- m and ~> uniquely determine comp (times) and id. --- +-- -- This kind of type class would not have been possible in previous -- versions of GHC; with the new kind system, however, we can abstract -- over kinds!2 Now, let’s create types for the additive and @@ -89,18 +89,17 @@ instance Monoidy (→) (,) () m ⇒ Monoid m where mempty = munit () instance Applicative Wrapper where - pure = return + pure x = runNT munit $ Id x (<*>) = ap -- instance (Functor m, Monoidy NT FC Id m) ⇒ Monad m where instance Monad Wrapper where - return x = runNT munit $ Id x x >>= f = runNT mjoin $ FC (f `fmap` x) -- And so the following works: test3 - = do { print (mappend mempty (Sum 2)) + = do { print (mappend mempty (Sum 2)) -- Sum 2 ; print (mappend (Product 2) (Product 3)) -- Product 6 ===================================== testsuite/tests/polykinds/MonoidsTF.hs ===================================== @@ -103,11 +103,10 @@ instance (MId (→) m ~ (), MComp (→) m ~ (,), Monoidy (→) m) mempty = munit () instance Applicative Wrapper where - pure = return + pure x = runNT munit $ Id x (<*>) = ap instance Monad Wrapper where - return x = runNT munit $ Id x x >>= f = runNT mjoin $ FC (f `fmap` x) -- And so the following works: ===================================== testsuite/tests/profiling/should_run/T3001-2.hs ===================================== @@ -90,22 +90,20 @@ instance Functor PutM where fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w instance Monad PutM where - return a = Put $ PairS a mempty - m >>= k = Put $ let PairS a w = unPut m PairS b w' = unPut (k a) in PairS b (w `mappend` w') - m >> k = Put $ +instance Applicative PutM where + pure a = Put $ PairS a mempty + (<*>) = ap + + m *> k = Put $ let PairS _ w = unPut m PairS b w' = unPut k in PairS b (w `mappend` w') -instance Applicative PutM where - pure = return - (<*>) = ap - tell :: Builder -> Put tell b = Put $ PairS () b @@ -189,9 +187,6 @@ joinZ bb lb | otherwise = L.Chunk bb lb instance Monad Get where - return a = Get (\s -> (a, s)) - {-# INLINE return #-} - m >>= k = Get (\s -> let (a, s') = unGet m s in unGet (k a) s') {-# INLINE (>>=) #-} @@ -200,7 +195,9 @@ instance MonadFail Get where fail = error "failDesc" instance Applicative Get where - pure = return + pure a = Get (\s -> (a, s)) + {-# INLINE pure #-} + (<*>) = ap getZ :: Get S ===================================== testsuite/tests/profiling/should_run/ioprof.hs ===================================== @@ -10,13 +10,13 @@ newtype M s a = M { unM :: s -> (s,a) } instance Monad (M s) where (M m) >>= k = M $ \s -> case m s of (s',a) -> unM (k a) s' - return a = M $ \s -> (s,a) + instance Functor (M s) where fmap = liftM instance Applicative (M s) where - pure = return + pure a = M $ \s -> (s,a) (<*>) = ap errorM :: String -> M s a ===================================== testsuite/tests/rebindable/rebindable2.hs ===================================== @@ -24,16 +24,15 @@ module Main where }; instance (Applicative TM) where { - pure = return; + pure a = MkTM (debugFunc "pure" (Prelude.pure a)); + (*>) ma mb = MkTM (debugFunc "*>" ((Prelude.*>) (unTM ma) (unTM mb))); (<*>) = ap; }; instance (Monad TM) where { - return a = MkTM (debugFunc "return" (Prelude.return a)); - + return = pure; (>>=) ma amb = MkTM (debugFunc ">>=" ((Prelude.>>=) (unTM ma) (\a -> unTM (amb a)))); - - (>>) ma mb = MkTM (debugFunc ">>" ((Prelude.>>) (unTM ma) (unTM mb))); + (>>) = (*>) }; instance (MonadFail TM) where { ===================================== testsuite/tests/rebindable/rebindable2.stdout ===================================== @@ -1,18 +1,18 @@ start test test_do failure -++ >> +++ *> ++ >>= ++ fail -- fail -- >>= --- >> +-- *> end test test_do failure start test test_do success -++ >> +++ *> ++ >>= -++ return --- return +++ pure +-- pure -- >>= --- >> +-- *> end test test_do success start test test_fromInteger 135 ===================================== testsuite/tests/simplCore/T9646/StrictPrim.hs ===================================== @@ -18,7 +18,10 @@ newtype StrictPrim s a instance Applicative (StrictPrim s) where {-# INLINE pure #-} - pure = return + pure !x = StrictPrim ( \ !s -> (# s, x #)) + + {-# INLINE (*>) #-} + (!m) *> (!k) = do { _ <- m ; k } {-# INLINE (<*>) #-} (<*>) a b = do f <- a ; v <- b ; return $! (f $! v) @@ -31,11 +34,6 @@ instance Functor (StrictPrim s) where instance Monad (StrictPrim s) where - {-# INLINE return #-} - return !x = StrictPrim ( \ !s -> (# s, x #)) - - {-# INLINE (>>) #-} - (!m) >> (!k) = do { _ <- m ; k } {-# INLINE (>>=) #-} (StrictPrim !m) >>= (!k) = ===================================== testsuite/tests/simplCore/should_run/T17744A.hs ===================================== @@ -17,10 +17,9 @@ instance Functor (Parser t) where fmap f p = apply (fmap f) p instance Applicative (Parser t) where - pure = return + pure = Result mempty instance Monad (Parser t) where - return = Result mempty Result s r >>= f = feed s (f r) p >>= f = apply (>>= f) p ===================================== testsuite/tests/simplCore/should_run/T3591.hs ===================================== @@ -1,4 +1,4 @@ -{- +{- Copyright 2009 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -20,7 +20,7 @@ -- | Module "Trampoline" defines the pipe computations and their basic building blocks. {-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, - TypeFamilies, KindSignatures, FlexibleContexts, + TypeFamilies, KindSignatures, FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances #-} @@ -75,11 +75,10 @@ instance Functor Identity where fmap = liftM instance Applicative Identity where - pure = return + pure a = Identity a (<*>) = ap instance Monad Identity where - return a = Identity a m >>= k = k (runIdentity m) newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)} @@ -89,11 +88,10 @@ instance (Monad m, Functor s) => Functor (Trampoline m s) where fmap = liftM instance (Monad m, Functor s) => Applicative (Trampoline m s) where - pure = return + pure x = Trampoline (return (Done x)) (<*>) = ap instance (Monad m, Functor s) => Monad (Trampoline m s) where - return x = Trampoline (return (Done x)) t >>= f = Trampoline (bounce t >>= apply f) where apply f (Done x) = bounce (f x) apply f (Suspend s) = return (Suspend (fmap (>>= f) s)) @@ -111,7 +109,7 @@ instance Functor (Await x) where data EitherFunctor l r x = LeftF (l x) | RightF (r x) instance (Functor l, Functor r) => Functor (EitherFunctor l r) where - fmap f v = trace "fmap Either" $ + fmap f v = trace "fmap Either" $ case v of LeftF l -> trace "fmap LeftF" $ LeftF (fmap f l) RightF r -> trace "fmap RightF" $ RightF (fmap f r) @@ -178,7 +176,7 @@ liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoli liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma) where inject :: TrampolineState m a x -> TrampolineState m d x inject (Done x) = Done x - inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $ + inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $ fmap liftOut (trace "poking a" a)) data Sink (m :: Type -> Type) a x = ===================================== testsuite/tests/typecheck/should_run/T1735_Help/State.hs ===================================== @@ -7,7 +7,6 @@ import Control.Monad (ap, liftM) newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } instance Monad m => Monad (StateT s m) where - return a = StateT $ \s -> return (a, s) m >>= k = StateT $ \s -> do ~(a, s') <- runStateT m s runStateT (k a) s' @@ -19,7 +18,7 @@ instance Monad m => Functor (StateT s m) where fmap = liftM instance Monad m => Applicative (StateT s m) where - pure = return + pure a = StateT $ \s -> pure (a, s) (<*>) = ap get :: Monad m => StateT s m s ===================================== testsuite/tests/typecheck/should_run/T4809_IdentityT.hs ===================================== @@ -19,9 +19,8 @@ data XML -- * IdentityT Monad Transformer newtype IdentityT m a = IdentityT { runIdentityT :: m a } - deriving (Functor, Monad, MonadIO, MonadPlus) + deriving (Functor, Applicative, Monad, MonadIO, MonadPlus) -instance Monad m => Applicative (IdentityT m) where instance Monad m => Alternative (IdentityT m) where instance MonadTrans IdentityT where ===================================== testsuite/tests/typecheck/should_run/T4809_XMLGenerator.hs ===================================== @@ -34,12 +34,9 @@ import Control.Monad (MonadPlus(..),liftM) -- | The monad transformer that allows a monad to generate XML values. newtype XMLGenT m a = XMLGenT (m a) - deriving (Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r, - MonadState s, MonadRWS r w s, MonadCont, MonadError e) - -instance Monad m => Applicative (XMLGenT m) where - pure = return - (<*>) = ap + deriving (Monad, Functor, Applicative, MonadIO, MonadPlus, MonadWriter w, + MonadReader r, MonadState s, MonadRWS r w s, MonadCont, + MonadError e) instance Monad m => Alternative (XMLGenT m) where ===================================== testsuite/tests/wcompat-warnings/Template.hs ===================================== @@ -13,3 +13,18 @@ instance Semi.Semigroup S where instance Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 + +newtype M a = M a + +instance Functor M where + fmap = undefined + +instance Applicative M where + liftA2 = undefined + pure = return + (*>) = (>>) + +instance Monad M where + return = undefined + (>>=) = undefined + (>>) = undefined ===================================== testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr ===================================== @@ -3,15 +3,47 @@ Template.hs:5:1: warning: [-Wsemigroup (in -Wcompat)] Local definition of ‘<>’ clashes with a future Prelude name. This will become an error in a future release. -Template.hs:11:3: warning: [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] +Template.hs:11:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] Noncanonical ‘(<>) = mappend’ definition detected in the instance declaration for ‘Semigroup S’. - Move definition from ‘mappend’ to ‘(<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + Suggested fix: + Move definition from ‘mappend’ to ‘(<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid -Template.hs:14:3: warning: [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] +Template.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] Noncanonical ‘mappend’ definition detected in the instance declaration for ‘Monoid S’. ‘mappend’ will eventually be removed in favour of ‘(<>)’ - Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + Suggested fix: + Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + +Template.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] + Noncanonical ‘pure = return’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘return’ to ‘pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +Template.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] + Noncanonical ‘(*>) = (>>)’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘(>>)’ to ‘(*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +Template.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] + Noncanonical ‘return’ definition detected + in the instance declaration for ‘Monad M’. + ‘return’ will eventually be removed in favour of ‘pure’ + Suggested fix: + Either remove definition for ‘return’ (recommended) or define as ‘return = pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +Template.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] + Noncanonical ‘(>>)’ definition detected + in the instance declaration for ‘Monad M’. + ‘(>>)’ will eventually be removed in favour of ‘(*>)’ + Suggested fix: + Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d21dfdfa320d24999a8c23c20a9e6a47cc36d385...888e9b81ab4e5f47e54bac3d06ed968e43ee58ca -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d21dfdfa320d24999a8c23c20a9e6a47cc36d385...888e9b81ab4e5f47e54bac3d06ed968e43ee58ca You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 22:35:24 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Mon, 08 May 2023 18:35:24 -0400 Subject: [Git][ghc/ghc][wip/orig-thunk-info] 67 commits: Allow generation of TTH syntax with TH Message-ID: <6459792c7c11a_38ffda717c1a346584f4@gitlab.mail> Ben Gamari pushed to branch wip/orig-thunk-info at Glasgow Haskell Compiler / GHC Commits: ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - beec0251 by Ben Gamari at 2023-05-08T18:02:41-04:00 compiler: Fingerprint more code generation flags Previously our recompilation check was quite inconsistent in its coverage of non-optimisation code generation flags. Specifically, we failed to account for most flags that would affect the behavior of generated code in ways that might affect the result of a program's execution (e.g. `-feager-blackholing`, `-fstrict-dicts`) - - - - - 110e07a3 by Ben Gamari at 2023-05-08T18:35:18-04:00 compiler: Record original thunk info tables on stack - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Type.hs-boot - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd91d3872914e8a813b08032ec4241114b0b0f35...110e07a3068e68efa1dfb7947d83a9fb9066deef -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd91d3872914e8a813b08032ec4241114b0b0f35...110e07a3068e68efa1dfb7947d83a9fb9066deef You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 22:42:11 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Mon, 08 May 2023 18:42:11 -0400 Subject: [Git][ghc/ghc][wip/T23070-pipeline-monad] Wibbles Message-ID: <64597ac35322d_38ffda7204343c66594a@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23070-pipeline-monad at Glasgow Haskell Compiler / GHC Commits: 7ed9bfea by Simon Peyton Jones at 2023-05-08T23:42:00+01:00 Wibbles - - - - - 5 changed files: - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Irred.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - testsuite/tests/typecheck/should_run/Typeable1.stderr Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -114,12 +114,16 @@ solveEquality ev eq_rel ty1 ty2 ; case mb_canon of { - Left irred_ct -> do { tryInertIrreds irred_ct + -- An IrredCt equality may be insoluble; but maybe not! + -- E.g. m a ~R# m b is not canonical, but may be + -- solved by a quantified constraint (T15290) + Left irred_ct -> do { tryInertIrreds irred_ct + ; tryQCsIrredEqCt irred_ct ; return (CIrredCan irred_ct) } ; - Right eq_ct -> do { interactEq eq_ct - ; tryFunDeps eq_ct - ; tryQCsEqCt eq_ct + Right eq_ct -> do { tryInertEqs eq_ct + ; tryFunDeps eq_ct + ; tryQCsEqCt eq_ct ; return (CEqCan eq_ct) } } } @@ -2477,7 +2481,7 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio {- ********************************************************************** * * - interactEq + tryInertEqs * * ********************************************************************** @@ -2517,8 +2521,8 @@ But it's not so simple: call to strictly_more_visible. -} -interactEq :: EqCt -> SolverStage () -interactEq work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) +tryInertEqs :: EqCt -> SolverStage () +tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) = Stage $ do { inerts <- getInertCans ; if | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item @@ -2670,23 +2674,16 @@ See -} -------------------- -{- -tryQCsIrredCt :: IrredCt -> SolverStage () -tryQCsIrredCt irred@(IrredCt { ir_ev = ev }) +tryQCsIrredEqCt :: IrredCt -> SolverStage () +tryQCsIrredEqCt irred@(IrredCt { ir_ev = ev }) | EqPred eq_rel t1 t2 <- classifyPredType (ctEvPred ev) = lookup_eq_in_qcis (CIrredCan irred) eq_rel t1 t2 - -- If the final_qci_check fails, we'll do continueWith on an IrredCt - -- That in turn will go down the Irred pipeline, so which deals with - -- the case where we have [G] Coercible (m a) (m b), and [W] m a ~R# m b - -- When we de-pipeline Irreds we may have to adjust here - - | otherwise -- All the calls come from in this module, where we deal - -- only with equalities, so ctEvPred ev) must be an equality. - -- Indeed, we could pass eq_rel, t1, t2 as arguments, to avoid - -- this can't happen case, but it's not a hot path, and this is - -- simple and robust + + | otherwise -- All the calls come from in this module, where we deal only with + -- equalities, so ctEvPred ev) must be an equality. Indeed, we could + -- pass eq_rel, t1, t2 as arguments, to avoid this can't-happen case, + -- but it's not a hot path, and this is simple and robust = pprPanic "solveIrredEquality" (ppr ev) --} -------------------- tryQCsEqCt :: EqCt -> SolverStage () ===================================== compiler/GHC/Tc/Solver/Irred.hs ===================================== @@ -3,7 +3,7 @@ {-# LANGUAGE RecursiveDo #-} module GHC.Tc.Solver.Irred( - solveIrred, tryInertIrreds + solveIrred, tryInertIrreds, tryQCsIrredCt ) where import GHC.Prelude ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -730,8 +730,9 @@ getHasGivenEqs tclvl ; return (has_ge, given_insols) } where insoluble_given_equality :: IrredCt -> Bool - insoluble_given_equality irred - = insolubleIrredCt irred && isGiven (irredCtEvidence irred) + -- Check for unreachability; specifically do not include UserError/Unsatisfiable + insoluble_given_equality (IrredCt { ir_ev = ev, ir_reason = reason }) + = isInsolubleReason reason && isGiven ev removeInertCts :: [Ct] -> InertCans -> InertCans -- ^ Remove inert constraints from the 'InertCans', for use when a ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -443,31 +443,32 @@ instance Outputable NotConcreteError where -- | Used to indicate extra information about why a CIrredCan is irreducible data CtIrredReason = IrredShapeReason - -- ^ this constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@) + -- ^ This constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@) + -- Also used for (U | NonCanonicalReason CheckTyEqResult - -- ^ an equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied; + -- ^ An equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied; -- the 'CheckTyEqResult' states exactly why | ReprEqReason - -- ^ an equality that cannot be decomposed because it is representational. + -- ^ An equality that cannot be decomposed because it is representational. -- Example: @a b ~R# Int at . -- These might still be solved later. -- INVARIANT: The constraint is a representational equality constraint | ShapeMismatchReason - -- ^ a nominal equality that relates two wholly different types, + -- ^ A nominal equality that relates two wholly different types, -- like @Int ~# Bool@ or @a b ~# 3 at . -- INVARIANT: The constraint is a nominal equality constraint | AbstractTyConReason - -- ^ an equality like @T a b c ~ Q d e@ where either @T@ or @Q@ + -- ^ An equality like @T a b c ~ Q d e@ where either @T@ or @Q@ -- is an abstract type constructor. See Note [Skolem abstract data] -- in GHC.Core.TyCon. -- INVARIANT: The constraint is an equality constraint between two TyConApps | PluginReason - -- ^ a typechecker plugin returned this in the pluginBagCts field + -- ^ A typechecker plugin returned this in the pluginBadCts field -- of TcPluginProgress instance Outputable CtIrredReason where @@ -1306,14 +1307,15 @@ insolubleWantedCt ct = insolubleCt ct && not (arisesFromGivens ct) && not (isWantedWantedFunDepOrigin (ctOrigin ct)) -insolubleIrredCt :: IrredCt -> Bool --- Returns True of Irred constraints that are /definitely/ insoluble -insolubleIrredCt (IrredCt { ir_reason = reason }) +insolubleEqIrredCt :: IrredCt -> Bool +-- True of Irred constraints that are +-- a) definitely insoluble +-- b) not (TypeError msg) +insolubleEqIrredCt (IrredCt { ir_reason = reason }) = isInsolubleReason reason --- | Returns True of constraints that are definitely insoluble, --- as well as TypeError constraints. --- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. +insolubleIrredCt :: IrredCt -> Bool +-- Returns True of Irred constraints that are /definitely/ insoluble -- -- This function is critical for accurate pattern-match overlap warnings. -- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver @@ -1321,16 +1323,9 @@ insolubleIrredCt (IrredCt { ir_reason = reason }) -- Note that this does not traverse through the constraint to find -- nested custom type errors: it only detects @TypeError msg :: Constraint@, -- and not e.g. @Eq (TypeError msg)@. --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- That's why it looks only for IrredCt, with an insoluble IrredCtReason -insolubleCt :: Ct -> Bool -insolubleCt ct - | isTopLevelUserTypeError (ctPred ct) = True - | CIrredCan ir_ct <- ct = insolubleIrredCt ir_ct - | otherwise = False - where +insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason }) + = isInsolubleReason reason + || isTopLevelUserTypeError (ctEvPred ev) -- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg" -- and "Unsatisfiable msg". It deliberately does not detect TypeError -- nested in a type (e.g. it does not use "containsUserTypeError"), as that @@ -1347,6 +1342,18 @@ insolubleCt ct -- > Assert 'True _errMsg = () -- > Assert _check errMsg = errMsg +-- | Returns True of constraints that are definitely insoluble, +-- as well as TypeError constraints. +-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. +-- +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- That's why it looks only for IrredCt; all insoluble constraints +-- are put into CIrredCan +insolubleCt :: Ct -> Bool +insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct +insolubleCt _ = False + -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool ===================================== testsuite/tests/typecheck/should_run/Typeable1.stderr ===================================== @@ -9,8 +9,8 @@ Typeable1.hs:22:5: error: [GHC-40564] [-Winaccessible-code (in -Wdefault), Werro TypeRep a -> TypeRep b -> TypeRep t, in a pattern binding in a 'do' block - Couldn't match type: ComposeK - with: a3 b3 + Couldn't match type: a3 b3 + with: ComposeK • In the pattern: App x y In a stmt of a 'do' block: App x y <- pure x In the expression: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ed9bfea3bc3f7174451b803eb0842617c522b19 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ed9bfea3bc3f7174451b803eb0842617c522b19 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 23:03:46 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Mon, 08 May 2023 19:03:46 -0400 Subject: [Git][ghc/ghc][wip/orig-thunk-info] compiler: Record original thunk info tables on stack Message-ID: <64597fd24ff79_38ffda7514fb5c68046e@gitlab.mail> Ben Gamari pushed to branch wip/orig-thunk-info at Glasgow Haskell Compiler / GHC Commits: 69321e89 by Ben Gamari at 2023-05-08T19:03:37-04:00 compiler: Record original thunk info tables on stack - - - - - 10 changed files: - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - docs/users_guide/debugging.rst - rts/StgMiscClosures.cmm - rts/include/rts/storage/Closures.h - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/Cmm/CLabel.hs ===================================== @@ -53,6 +53,7 @@ module GHC.Cmm.CLabel ( mkDirty_MUT_VAR_Label, mkMUT_VAR_CLEAN_infoLabel, mkNonmovingWriteBarrierEnabledLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, @@ -641,7 +642,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable -- Constructing Cmm Labels mkDirty_MUT_VAR_Label, mkNonmovingWriteBarrierEnabledLabel, - mkUpdInfoLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, mkMAP_DIRTY_infoLabel, @@ -655,6 +656,7 @@ mkDirty_MUT_VAR_Label, mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData +mkOrigThunkInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo ===================================== compiler/GHC/Driver/Config/StgToCmm.hs ===================================== @@ -37,6 +37,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig , stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags , stgToCmmSCCProfiling = sccProfilingEnabled dflags , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags + , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo dflags , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags , stgToCmmOmitYields = gopt Opt_OmitYields dflags , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -329,6 +329,7 @@ data GeneralFlag | Opt_IgnoreHpcChanges | Opt_ExcessPrecision | Opt_EagerBlackHoling + | Opt_OrigThunkInfo | Opt_NoHsMain | Opt_SplitSections | Opt_StgStats @@ -558,6 +559,7 @@ codeGenFlags = EnumSet.fromList -- Flags that affect debugging information , Opt_DistinctConstructorTables , Opt_InfoTableMap + , Opt_OrigThunkInfo ] data WarningFlag = ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3481,6 +3481,7 @@ fFlagsDeps = [ flagSpec "do-eta-reduction" Opt_DoEtaReduction, flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "orig-thunk-info" Opt_OrigThunkInfo, flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -730,7 +730,8 @@ setupUpdate closure_info node body lbl | bh = mkBHUpdInfoLabel | otherwise = mkUpdInfoLabel - pushUpdateFrame lbl (CmmReg (CmmLocal node)) body + pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -738,7 +739,8 @@ setupUpdate closure_info node body ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf node - ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } + ; pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body } else do {tickyUpdateFrameOmitted; body} } @@ -754,8 +756,7 @@ pushUpdateFrame lbl updatee body = do updfr <- getUpdFrameOff profile <- getProfile - let - hdr = fixedHdrSize profile + let hdr = fixedHdrSize profile frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) -- emitUpdateFrame (CmmStackSlot Old frame) lbl updatee @@ -773,6 +774,47 @@ emitUpdateFrame frame lbl updatee = do emitStore (cmmOffset platform frame off_updatee) updatee initUpdFrameProf frame +----------------------------------------------------------------------------- +-- Original thunk info table frames +-- +-- Note [Original thunk info table frames] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very +-- useful to know which thunks the program is in the process of evaluating. +-- However, in the case of updateable thunks this can be very difficult +-- to determine since the process of blackholing overwrites the thunk's +-- info table pointer. +-- +-- To help in such situations we provide the -forig-thunk-info flag. This enables +-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to +-- accompany each update frame. As the name suggests, this frame captures the +-- the original info table of the thunk being updated. The entry code for these +-- frames has no operational effects; the frames merely exist as breadcrumbs +-- for debugging. + +pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode () +pushOrigThunkInfoFrame closure_info body = do + cfg <- getStgToCmmConfig + if stgToCmmOrigThunkInfo cfg + then do_it + else body + where + orig_itbl = mkLblExpr (closureInfoLabel closure_info) + do_it = do + updfr <- getUpdFrameOff + profile <- getProfile + let platform = profilePlatform profile + hdr = fixedHdrSize profile + orig_info_frame_sz = + hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile) + off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (profileConstants profile) + frame_off = updfr + orig_info_frame_sz + frame = CmmStackSlot Old frame_off + -- + emitStore frame (mkLblExpr mkOrigThunkInfoLabel) + emitStore (cmmOffset platform frame off_orig_info) orig_itbl + withUpdFrameOff frame_off body + ----------------------------------------------------------------------------- -- Entering a CAF -- ===================================== compiler/GHC/StgToCmm/Config.hs ===================================== @@ -49,6 +49,7 @@ data StgToCmmConfig = StgToCmmConfig , stgToCmmFastPAPCalls :: !Bool -- ^ , stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled , stgToCmmEagerBlackHole :: !Bool -- ^ + , stgToCmmOrigThunkInfo :: !Bool -- ^ Push @stg_orig_thunk_info@ frames during thunk update. , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See note [Mapping -- Info Tables to Source Positions] , stgToCmmOmitYields :: !Bool -- ^ true means omit heap checks when no allocation is performed ===================================== docs/users_guide/debugging.rst ===================================== @@ -1072,6 +1072,18 @@ Checking for consistency cases. This is helpful when debugging demand analysis or type checker bugs which can sometimes manifest as segmentation faults. +.. ghc-flag:: -forig-thunk-info + :shortdesc: Generate ``stg_orig_thunk_info`` stack frames on thunk entry + :type: dynamic + + When debugging cyclic thunks it can be helpful to know the original + info table of a thunk being evaluated. This flag enables code generation logic + to facilitate this, producing a ``stg_orig_thunk_info`` stack frame alongside + the usual update frame; such ``orig_thunk`` frames have no operational + effect but capture the original info table of the updated thunk for inspection + by debugging tools. See ``Note [Original thunk info table frames]`` in + ``GHC.StgToCmm.Bind`` for details. + .. ghc-flag:: -fcheck-prim-bounds :shortdesc: Instrument array primops with bounds checks. :type: dynamic ===================================== rts/StgMiscClosures.cmm ===================================== @@ -45,6 +45,17 @@ import CLOSURE stg_ret_t_info; import CLOSURE stg_ret_v_info; #endif +/* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */ +INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, + W_ info_ptr, + W_ thunk_info_ptr) + /* no args => explicit stack */ +{ + unwind Sp = W_[Sp + WDS(2)]; + Sp_adj(2); + jump %ENTRY_CODE(Sp(0)) [*]; // NB. all registers live! +} + /* ---------------------------------------------------------------------------- Stack underflow ------------------------------------------------------------------------- */ ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -261,6 +261,13 @@ typedef struct _StgUpdateFrame { StgClosure *updatee; } StgUpdateFrame; +// Thunk update frame +// +// Closure types: RET_SMALL +typedef struct _StgOrigThunkInfoFrame { + StgHeader header; + StgInfoTable *info_ptr; +} StgOrigThunkInfoFrame; // Closure types: RET_SMALL typedef struct { ===================================== utils/deriveConstants/Main.hs ===================================== @@ -437,6 +437,7 @@ wanteds os = concat ,structField Both "StgEntCounter" "entry_count" ,closureSize Both "StgUpdateFrame" + ,closureSize Both "StgOrigThunkInfoFrame" ,closureSize C "StgCatchFrame" ,closureSize C "StgStopFrame" ,closureSize C "StgDeadThreadFrame" @@ -479,6 +480,7 @@ wanteds os = concat ,structSize C "StgTSOProfInfo" ,closureField Both "StgUpdateFrame" "updatee" + ,closureField Both "StgOrigThunkInfoFrame" "info_ptr" ,closureField C "StgCatchFrame" "handler" ,closureField C "StgCatchFrame" "exceptions_blocked" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69321e899e949d1a4c7eeb881e1493d6d6e0acb8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69321e899e949d1a4c7eeb881e1493d6d6e0acb8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 23:11:12 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 08 May 2023 19:11:12 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] Add structured error messages for GHC.IfaceToCore Message-ID: <64598190a8acc_38ffda7576910068862e@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 24effc02 by Torsten Schmits at 2023-05-08T19:11:07-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 4 changed files: - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Types/Error/Codes.hs Changes: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -65,6 +65,8 @@ interfaceErrorHints = \ case missingInterfaceErrorHints err Can'tFindNameInInterface {} -> noHints + CircularImport {} -> + noHints missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] missingInterfaceErrorHints = \case @@ -86,6 +88,8 @@ interfaceErrorReason (Can'tFindInterface err _) = missingInterfaceErrorReason err interfaceErrorReason (Can'tFindNameInInterface {}) = ErrorWithoutFlag +interfaceErrorReason (CircularImport {}) + = ErrorWithoutFlag missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason missingInterfaceErrorReason = \ case @@ -287,6 +291,9 @@ interfaceErrorDiagnostic opts = \ case LookingForSig sig -> hang (text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon) 2 (missingInterfaceErrorDiagnostic opts err) + CircularImport mod -> + text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc readInterfaceErrorDiagnostic = \ case ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -45,6 +45,7 @@ data IfaceMessage | Can'tFindNameInInterface Name [TyThing] -- possibly relevant TyThings + | CircularImport !Module deriving Generic data MissingInterfaceError ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -605,7 +605,7 @@ tcHiBootIface hsc_src mod (LookingForHiBoot mod) in failWithTc (TcRnInterfaceError diag) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) + NotBoot -> failWithTc (TcRnInterfaceError (CircularImport mod)) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} @@ -613,11 +613,6 @@ tcHiBootIface hsc_src mod need = text "Need the hi-boot interface for" <+> ppr mod <+> text "to compare against the Real Thing" - moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) - <+> text "depends on itself" - - - mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo mkSelfBootInfo iface mds = do -- NB: This is computed DIRECTLY from the ModIface rather ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -719,6 +719,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "NoUnitIdMatching" = 51294 GhcDiagnosticCode "NotAModule" = 35235 GhcDiagnosticCode "Can'tFindNameInInterface" = 83249 + GhcDiagnosticCode "CircularImport" = 75429 GhcDiagnosticCode "HiModuleNameMismatchWarn" = 53693 GhcDiagnosticCode "ExceptionOccurred" = 47808 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24effc0241d63dffc8f0add3c2092a860187c231 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24effc0241d63dffc8f0add3c2092a860187c231 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 23:20:38 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Mon, 08 May 2023 19:20:38 -0400 Subject: [Git][ghc/ghc][wip/orig-thunk-info] 2 commits: compiler: Fingerprint more code generation flags Message-ID: <645983c61fd8d_38ffda76ebebfc698941@gitlab.mail> Ben Gamari pushed to branch wip/orig-thunk-info at Glasgow Haskell Compiler / GHC Commits: 70e0c8a2 by Ben Gamari at 2023-05-08T19:20:30-04:00 compiler: Fingerprint more code generation flags Previously our recompilation check was quite inconsistent in its coverage of non-optimisation code generation flags. Specifically, we failed to account for most flags that would affect the behavior of generated code in ways that might affect the result of a program's execution (e.g. `-feager-blackholing`, `-fstrict-dicts`) - - - - - 1d75c827 by Ben Gamari at 2023-05-08T19:20:30-04:00 compiler: Record original thunk info tables on stack - - - - - 11 changed files: - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Recomp/Flags.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - docs/users_guide/debugging.rst - rts/StgMiscClosures.cmm - rts/include/rts/storage/Closures.h - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/Cmm/CLabel.hs ===================================== @@ -53,6 +53,7 @@ module GHC.Cmm.CLabel ( mkDirty_MUT_VAR_Label, mkMUT_VAR_CLEAN_infoLabel, mkNonmovingWriteBarrierEnabledLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, @@ -641,7 +642,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable -- Constructing Cmm Labels mkDirty_MUT_VAR_Label, mkNonmovingWriteBarrierEnabledLabel, - mkUpdInfoLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, mkMAP_DIRTY_infoLabel, @@ -655,6 +656,7 @@ mkDirty_MUT_VAR_Label, mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData +mkOrigThunkInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo ===================================== compiler/GHC/Driver/Config/StgToCmm.hs ===================================== @@ -37,6 +37,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig , stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags , stgToCmmSCCProfiling = sccProfilingEnabled dflags , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags + , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo dflags , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags , stgToCmmOmitYields = gopt Opt_OmitYields dflags , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -5,6 +5,7 @@ module GHC.Driver.Flags , GeneralFlag(..) , Language(..) , optimisationFlags + , codeGenFlags -- * Warnings , WarningGroup(..) @@ -328,6 +329,7 @@ data GeneralFlag | Opt_IgnoreHpcChanges | Opt_ExcessPrecision | Opt_EagerBlackHoling + | Opt_OrigThunkInfo | Opt_NoHsMain | Opt_SplitSections | Opt_StgStats @@ -473,15 +475,11 @@ data GeneralFlag | Opt_G_NoOptCoercion deriving (Eq, Show, Enum) --- Check whether a flag should be considered an "optimisation flag" --- for purposes of recompilation avoidance (see --- Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags). Being listed here is --- not a guarantee that the flag has no other effect. We could, and --- perhaps should, separate out the flags that have some minor impact on --- program semantics and/or error behavior (e.g., assertions), but --- then we'd need to go to extra trouble (and an additional flag) --- to allow users to ignore the optimisation level even though that --- means ignoring some change. +-- | The set of flags which affect optimisation for the purposes of +-- recompilation avoidance. Specifically, these include flags which +-- affect code generation but not the semantics of the program. +-- +-- See Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags) optimisationFlags :: EnumSet GeneralFlag optimisationFlags = EnumSet.fromList [ Opt_CallArity @@ -489,7 +487,6 @@ optimisationFlags = EnumSet.fromList , Opt_LateDmdAnal , Opt_KillAbsence , Opt_KillOneShot - , Opt_FullLaziness , Opt_FloatIn , Opt_LateSpecialise , Opt_Specialise @@ -503,7 +500,6 @@ optimisationFlags = EnumSet.fromList , Opt_SpecConstr , Opt_SpecConstrKeen , Opt_DoLambdaEtaExpansion - , Opt_IgnoreAsserts , Opt_DoEtaReduction , Opt_CaseMerge , Opt_CaseFolding @@ -513,16 +509,12 @@ optimisationFlags = EnumSet.fromList , Opt_EnableRewriteRules , Opt_RegsGraph , Opt_RegsIterative - , Opt_PedanticBottoms , Opt_LlvmTBAA - , Opt_LlvmFillUndefWithGarbage , Opt_IrrefutableTuples , Opt_CmmSink , Opt_CmmElimCommonBlocks , Opt_AsmShortcutting - , Opt_OmitYields , Opt_FunToThunk - , Opt_DictsStrict , Opt_DmdTxDictSel , Opt_Loopification , Opt_CfgBlocklayout @@ -531,8 +523,43 @@ optimisationFlags = EnumSet.fromList , Opt_WorkerWrapper , Opt_WorkerWrapperUnlift , Opt_SolveConstantDicts + ] + +-- | The set of flags which affect code generation and can change a program's +-- runtime behavior (other than performance). These include flags which affect: +-- +-- * asympototic space behavior (e.g. -ffull-laziness) +-- * user visible debugging information (e.g. info table provenance) +-- * the ability to catch runtime errors (e.g. -fignore-asserts) +-- * the runtime result of the program (e.g. -fomit-yields) +-- * which code or interface file declarations are emitted +-- +codeGenFlags :: EnumSet GeneralFlag +codeGenFlags = EnumSet.fromList + [ -- Flags that affect runtime result + Opt_EagerBlackHoling + , Opt_ExcessPrecision + , Opt_DictsStrict + , Opt_PedanticBottoms + , Opt_OmitYields + + -- Flags that affect generated code + , Opt_ExposeAllUnfoldings + , Opt_NoTypeableBinds + + -- Flags that affect catching of runtime errors , Opt_CatchNonexhaustiveCases , Opt_IgnoreAsserts + , Opt_LlvmFillUndefWithGarbage + , Opt_DoTagInferenceChecks + + -- Flags that affect space + , Opt_FullLaziness + + -- Flags that affect debugging information + , Opt_DistinctConstructorTables + , Opt_InfoTableMap + , Opt_OrigThunkInfo ] data WarningFlag = ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -66,6 +66,7 @@ module GHC.Driver.Session ( makeDynFlagsConsistent, positionIndependent, optimisationFlags, + codeGenFlags, setFlagsFromEnvFile, pprDynFlagsDiff, flagSpecOf, @@ -3481,6 +3482,7 @@ fFlagsDeps = [ flagSpec "do-eta-reduction" Opt_DoEtaReduction, flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "orig-thunk-info" Opt_OrigThunkInfo, flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, ===================================== compiler/GHC/Iface/Recomp/Flags.hs ===================================== @@ -67,7 +67,10 @@ fingerprintDynFlags hsc_env this_mod nameio = ticky = map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag] - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters)) + -- Other flags which affect code generation + codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) + + flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters)) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -730,7 +730,8 @@ setupUpdate closure_info node body lbl | bh = mkBHUpdInfoLabel | otherwise = mkUpdInfoLabel - pushUpdateFrame lbl (CmmReg (CmmLocal node)) body + pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -738,7 +739,8 @@ setupUpdate closure_info node body ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf node - ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } + ; pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body } else do {tickyUpdateFrameOmitted; body} } @@ -754,8 +756,7 @@ pushUpdateFrame lbl updatee body = do updfr <- getUpdFrameOff profile <- getProfile - let - hdr = fixedHdrSize profile + let hdr = fixedHdrSize profile frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) -- emitUpdateFrame (CmmStackSlot Old frame) lbl updatee @@ -773,6 +774,47 @@ emitUpdateFrame frame lbl updatee = do emitStore (cmmOffset platform frame off_updatee) updatee initUpdFrameProf frame +----------------------------------------------------------------------------- +-- Original thunk info table frames +-- +-- Note [Original thunk info table frames] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very +-- useful to know which thunks the program is in the process of evaluating. +-- However, in the case of updateable thunks this can be very difficult +-- to determine since the process of blackholing overwrites the thunk's +-- info table pointer. +-- +-- To help in such situations we provide the -forig-thunk-info flag. This enables +-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to +-- accompany each update frame. As the name suggests, this frame captures the +-- the original info table of the thunk being updated. The entry code for these +-- frames has no operational effects; the frames merely exist as breadcrumbs +-- for debugging. + +pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode () +pushOrigThunkInfoFrame closure_info body = do + cfg <- getStgToCmmConfig + if stgToCmmOrigThunkInfo cfg + then do_it + else body + where + orig_itbl = mkLblExpr (closureInfoLabel closure_info) + do_it = do + updfr <- getUpdFrameOff + profile <- getProfile + let platform = profilePlatform profile + hdr = fixedHdrSize profile + orig_info_frame_sz = + hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile) + off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (profileConstants profile) + frame_off = updfr + orig_info_frame_sz + frame = CmmStackSlot Old frame_off + -- + emitStore frame (mkLblExpr mkOrigThunkInfoLabel) + emitStore (cmmOffset platform frame off_orig_info) orig_itbl + withUpdFrameOff frame_off body + ----------------------------------------------------------------------------- -- Entering a CAF -- ===================================== compiler/GHC/StgToCmm/Config.hs ===================================== @@ -49,6 +49,7 @@ data StgToCmmConfig = StgToCmmConfig , stgToCmmFastPAPCalls :: !Bool -- ^ , stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled , stgToCmmEagerBlackHole :: !Bool -- ^ + , stgToCmmOrigThunkInfo :: !Bool -- ^ Push @stg_orig_thunk_info@ frames during thunk update. , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See note [Mapping -- Info Tables to Source Positions] , stgToCmmOmitYields :: !Bool -- ^ true means omit heap checks when no allocation is performed ===================================== docs/users_guide/debugging.rst ===================================== @@ -1072,6 +1072,18 @@ Checking for consistency cases. This is helpful when debugging demand analysis or type checker bugs which can sometimes manifest as segmentation faults. +.. ghc-flag:: -forig-thunk-info + :shortdesc: Generate ``stg_orig_thunk_info`` stack frames on thunk entry + :type: dynamic + + When debugging cyclic thunks it can be helpful to know the original + info table of a thunk being evaluated. This flag enables code generation logic + to facilitate this, producing a ``stg_orig_thunk_info`` stack frame alongside + the usual update frame; such ``orig_thunk`` frames have no operational + effect but capture the original info table of the updated thunk for inspection + by debugging tools. See ``Note [Original thunk info table frames]`` in + ``GHC.StgToCmm.Bind`` for details. + .. ghc-flag:: -fcheck-prim-bounds :shortdesc: Instrument array primops with bounds checks. :type: dynamic ===================================== rts/StgMiscClosures.cmm ===================================== @@ -45,6 +45,17 @@ import CLOSURE stg_ret_t_info; import CLOSURE stg_ret_v_info; #endif +/* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */ +INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, + W_ info_ptr, + W_ thunk_info_ptr) + /* no args => explicit stack */ +{ + unwind Sp = W_[Sp + WDS(2)]; + Sp_adj(2); + jump %ENTRY_CODE(Sp(0)) [*]; // NB. all registers live! +} + /* ---------------------------------------------------------------------------- Stack underflow ------------------------------------------------------------------------- */ ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -261,6 +261,13 @@ typedef struct _StgUpdateFrame { StgClosure *updatee; } StgUpdateFrame; +// Thunk update frame +// +// Closure types: RET_SMALL +typedef struct _StgOrigThunkInfoFrame { + StgHeader header; + StgInfoTable *info_ptr; +} StgOrigThunkInfoFrame; // Closure types: RET_SMALL typedef struct { ===================================== utils/deriveConstants/Main.hs ===================================== @@ -437,6 +437,7 @@ wanteds os = concat ,structField Both "StgEntCounter" "entry_count" ,closureSize Both "StgUpdateFrame" + ,closureSize Both "StgOrigThunkInfoFrame" ,closureSize C "StgCatchFrame" ,closureSize C "StgStopFrame" ,closureSize C "StgDeadThreadFrame" @@ -479,6 +480,7 @@ wanteds os = concat ,structSize C "StgTSOProfInfo" ,closureField Both "StgUpdateFrame" "updatee" + ,closureField Both "StgOrigThunkInfoFrame" "info_ptr" ,closureField C "StgCatchFrame" "handler" ,closureField C "StgCatchFrame" "exceptions_blocked" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/69321e899e949d1a4c7eeb881e1493d6d6e0acb8...1d75c8271a8cc3ee6ff4318d935f84e34ed44072 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/69321e899e949d1a4c7eeb881e1493d6d6e0acb8...1d75c8271a8cc3ee6ff4318d935f84e34ed44072 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 23:42:38 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Mon, 08 May 2023 19:42:38 -0400 Subject: [Git][ghc/ghc][wip/T23070-pipeline-monad] Wibble2 Message-ID: <645988ee8502_38ffda78df66b4714715@gitlab.mail> Simon Peyton Jones pushed to branch wip/T23070-pipeline-monad at Glasgow Haskell Compiler / GHC Commits: 8859a484 by Simon Peyton Jones at 2023-05-09T00:42:24+01:00 Wibble2 - - - - - 1 changed file: - compiler/GHC/Tc/Types/Constraint.hs Changes: ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1307,13 +1307,6 @@ insolubleWantedCt ct = insolubleCt ct && not (arisesFromGivens ct) && not (isWantedWantedFunDepOrigin (ctOrigin ct)) -insolubleEqIrredCt :: IrredCt -> Bool --- True of Irred constraints that are --- a) definitely insoluble --- b) not (TypeError msg) -insolubleEqIrredCt (IrredCt { ir_reason = reason }) - = isInsolubleReason reason - insolubleIrredCt :: IrredCt -> Bool -- Returns True of Irred constraints that are /definitely/ insoluble -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8859a484019dd1674bf44b1458f11da30a12c169 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8859a484019dd1674bf44b1458f11da30a12c169 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon May 8 23:43:40 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Mon, 08 May 2023 19:43:40 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/T23070-dicts Message-ID: <6459892c101e_38ffda798e7244715663@gitlab.mail> Simon Peyton Jones pushed new branch wip/T23070-dicts at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T23070-dicts You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 01:41:30 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 08 May 2023 21:41:30 -0400 Subject: [Git][ghc/ghc][master] rts: Fix data-race in hs_init_ghc Message-ID: <6459a4ca3212_38ffda8038ff74755490@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3e3a6be4 by Ben Gamari at 2023-05-08T12:15:19+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 1 changed file: - rts/RtsStartup.c Changes: ===================================== rts/RtsStartup.c ===================================== @@ -68,7 +68,7 @@ #endif // Count of how many outstanding hs_init()s there have been. -static int hs_init_count = 0; +static StgWord hs_init_count = 0; static bool rts_shutdown = false; #if defined(mingw32_HOST_OS) @@ -242,8 +242,9 @@ hs_init_with_rtsopts(int *argc, char **argv[]) void hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) { - hs_init_count++; - if (hs_init_count > 1) { + // N.B. atomic_inc returns the new value. + StgWord init_count = atomic_inc(&hs_init_count, 1); + if (init_count > 1) { // second and subsequent inits are ignored return; } @@ -452,15 +453,17 @@ hs_exit_(bool wait_foreign) { uint32_t g, i; - if (hs_init_count <= 0) { - errorBelch("warning: too many hs_exit()s"); + // N.B. atomic_dec returns the new value. + StgInt init_count = (StgInt)atomic_dec(&hs_init_count); + if (init_count > 0) { + // ignore until it's the last one return; } - hs_init_count--; - if (hs_init_count > 0) { - // ignore until it's the last one + if (init_count < 0) { + errorBelch("warning: too many hs_exit()s"); return; } + rts_shutdown = true; /* start timing the shutdown */ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e3a6be4023189b2d637beda240e23fa9e856810 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e3a6be4023189b2d637beda240e23fa9e856810 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 01:42:08 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 08 May 2023 21:42:08 -0400 Subject: [Git][ghc/ghc][master] Add structured error messages for GHC.IfaceToCore Message-ID: <6459a4f07e595_38ffda8030cc00759378@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 78c8dc50 by Torsten Schmits at 2023-05-08T21:41:51-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 4 changed files: - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Types/Error/Codes.hs Changes: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -65,6 +65,8 @@ interfaceErrorHints = \ case missingInterfaceErrorHints err Can'tFindNameInInterface {} -> noHints + CircularImport {} -> + noHints missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] missingInterfaceErrorHints = \case @@ -86,6 +88,8 @@ interfaceErrorReason (Can'tFindInterface err _) = missingInterfaceErrorReason err interfaceErrorReason (Can'tFindNameInInterface {}) = ErrorWithoutFlag +interfaceErrorReason (CircularImport {}) + = ErrorWithoutFlag missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason missingInterfaceErrorReason = \ case @@ -287,6 +291,9 @@ interfaceErrorDiagnostic opts = \ case LookingForSig sig -> hang (text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon) 2 (missingInterfaceErrorDiagnostic opts err) + CircularImport mod -> + text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc readInterfaceErrorDiagnostic = \ case ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -45,6 +45,7 @@ data IfaceMessage | Can'tFindNameInInterface Name [TyThing] -- possibly relevant TyThings + | CircularImport !Module deriving Generic data MissingInterfaceError ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -605,7 +605,7 @@ tcHiBootIface hsc_src mod (LookingForHiBoot mod) in failWithTc (TcRnInterfaceError diag) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) + NotBoot -> failWithTc (TcRnInterfaceError (CircularImport mod)) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} @@ -613,11 +613,6 @@ tcHiBootIface hsc_src mod need = text "Need the hi-boot interface for" <+> ppr mod <+> text "to compare against the Real Thing" - moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) - <+> text "depends on itself" - - - mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo mkSelfBootInfo iface mds = do -- NB: This is computed DIRECTLY from the ModIface rather ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -719,6 +719,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "NoUnitIdMatching" = 51294 GhcDiagnosticCode "NotAModule" = 35235 GhcDiagnosticCode "Can'tFindNameInInterface" = 83249 + GhcDiagnosticCode "CircularImport" = 75429 GhcDiagnosticCode "HiModuleNameMismatchWarn" = 53693 GhcDiagnosticCode "ExceptionOccurred" = 47808 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78c8dc509eacef5a5f09601b6bd004e13ae3a4c3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78c8dc509eacef5a5f09601b6bd004e13ae3a4c3 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 04:01:33 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 00:01:33 -0400 Subject: [Git][ghc/ghc][wip/glossary] Use glossary directive Message-ID: <6459c59d34c3e_38ffda86417ff479099d@gitlab.mail> Ben Gamari pushed to branch wip/glossary at Glasgow Haskell Compiler / GHC Commits: 774cfaee by Ben Gamari at 2023-05-09T04:01:31+00:00 Use glossary directive - - - - - 1 changed file: - docs/users_guide/glossary.rst Changes: ===================================== docs/users_guide/glossary.rst ===================================== @@ -1,12 +1,13 @@ Glossary ======== -technology preview:: +.. glossary:: + technology preview - GHC will occassionally ship features advertised as being in a *technology - preview* state. Such features are generally opt-in in nature (e.g. new - language extensions) and may have various shortcomings. These may include - known bugs (which we will try to document), lacking optimisation, and - unhandled interactions with other language features. As such, behavior - of such features may change in the future. However, we do expect features - to converge to non-preview state over the course of a few GHC major releases. + GHC will occassionally ship features advertised as being in a *technology + preview* state. Such features are generally opt-in in nature (e.g. new + language extensions) and may have various shortcomings. These may include + known bugs (which we will try to document), lacking optimisation, and + unhandled interactions with other language features. As such, behavior + of such features may change in the future. However, we do expect features + to converge to non-preview state over the course of a few GHC major releases. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/774cfaeefd521a15f39d4aa378b00758ee081e58 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/774cfaeefd521a15f39d4aa378b00758ee081e58 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 04:19:42 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 00:19:42 -0400 Subject: [Git][ghc/ghc][wip/orig-thunk-info] 29 commits: Add sized primitive literal syntax Message-ID: <6459c9dea086c_38ffda87052ff8793178@gitlab.mail> Ben Gamari pushed to branch wip/orig-thunk-info at Glasgow Haskell Compiler / GHC Commits: 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 3e3a6be4 by Ben Gamari at 2023-05-08T12:15:19+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 78c8dc50 by Torsten Schmits at 2023-05-08T21:41:51-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 26c3ab3e by Ben Gamari at 2023-05-09T00:18:49-04:00 compiler: Fingerprint more code generation flags Previously our recompilation check was quite inconsistent in its coverage of non-optimisation code generation flags. Specifically, we failed to account for most flags that would affect the behavior of generated code in ways that might affect the result of a program's execution (e.g. `-feager-blackholing`, `-fstrict-dicts`) - - - - - 09fb21d7 by Ben Gamari at 2023-05-09T00:18:49-04:00 compiler: Record original thunk info tables on stack - - - - - 30 changed files: - .gitlab-ci.yml - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Recomp/Flags.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1d75c8271a8cc3ee6ff4318d935f84e34ed44072...09fb21d748fbc5d6805dcf8e260c16b2ef686fcf -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1d75c8271a8cc3ee6ff4318d935f84e34ed44072...09fb21d748fbc5d6805dcf8e260c16b2ef686fcf You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 04:30:57 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 00:30:57 -0400 Subject: [Git][ghc/ghc][wip/T13660] 31 commits: Optimized Foldable methods for Data.Functor.Compose Message-ID: <6459cc81b2d83_38ffda870d63447975bb@gitlab.mail> Ben Gamari pushed to branch wip/T13660 at Glasgow Haskell Compiler / GHC Commits: 8c98deba by Armando Ramirez at 2023-03-23T09:19:32-04:00 Optimized Foldable methods for Data.Functor.Compose Explicitly define length, elem, etc. in Foldable instance for Data.Functor.Compose Implementation of https://github.com/haskell/core-libraries-committee/issues/57 - - - - - bc066108 by Armando Ramirez at 2023-03-23T09:19:32-04:00 Additional optimized versions - - - - - 80fce576 by Bodigrim at 2023-03-23T09:19:32-04:00 Simplify minimum/maximum in instance Foldable (Compose f g) - - - - - 8cb88a5a by Bodigrim at 2023-03-23T09:19:32-04:00 Update changelog to mention changes to instance Foldable (Compose f g) - - - - - e1c8c41d by Torsten Schmits at 2023-03-23T09:20:13-04:00 Add structured error messages for GHC.Tc.TyCl.PatSyn Tracking ticket: #20117 MR: !10158 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - f932c589 by Adam Gundry at 2023-03-24T02:36:09-04:00 Allow WARNING pragmas to be controlled with custom categories Closes #17209. This implements GHC Proposal 541, allowing a WARNING pragma to be annotated with a category like so: {-# WARNING in "x-partial" head "This function is undefined on empty lists." #-} The user can then enable, disable and set the severity of such warnings using command-line flags `-Wx-partial`, `-Werror=x-partial` and so on. There is a new warning group `-Wextended-warnings` containing all these warnings. Warnings without a category are treated as if the category was `deprecations`, and are (still) controlled by the flags `-Wdeprecations` and `-Wwarnings-deprecations`. Updates Haddock submodule. - - - - - 0426515b by Adam Gundry at 2023-03-24T02:36:09-04:00 Move mention of warning groups change to 9.8.1 release notes - - - - - b8d783d2 by Ben Gamari at 2023-03-24T02:36:45-04:00 nativeGen/AArch64: Fix bitmask immediate predicate Previously the predicate for determining whether a logical instruction operand could be encoded as a bitmask immediate was far too conservative. This meant that, e.g., pointer untagged required five instructions whereas it should only require one. Fixes #23030. - - - - - 46120bb6 by Joachim Breitner at 2023-03-24T13:09:43-04:00 User's guide: Improve docs for -Wall previously it would list the warnings _not_ enabled by -Wall. That’s unnecessary round-about and was out of date. So let's just name the relevant warnings (based on `compiler/GHC/Driver/Flags.hs`). - - - - - 509d1f11 by Ben Gamari at 2023-03-24T13:10:20-04:00 codeGen/tsan: Disable instrumentation of unaligned stores There is some disagreement regarding the prototype of `__tsan_unaligned_write` (specifically whether it takes just the written address, or the address and the value as an argument). Moreover, I have observed crashes which appear to be due to it. Disable instrumentation of unaligned stores as a temporary mitigation. Fixes #23096. - - - - - 6a73655f by Li-yao Xia at 2023-03-25T00:02:44-04:00 base: Document GHC versions associated with past base versions in the changelog - - - - - 43bd7694 by Teo Camarasu at 2023-03-25T00:03:24-04:00 Add regression test for #17574 This test currently fails in the nonmoving way - - - - - f2d56bf7 by Teo Camarasu at 2023-03-25T00:03:24-04:00 fix: account for large and compact object stats with nonmoving gc Make sure that we keep track of the size of large and compact objects that have been moved onto the nonmoving heap. We keep track of their size and add it to the amount of live bytes in nonmoving segments to get the total size of the live nonmoving heap. Resolves #17574 - - - - - 7131b705 by David Feuer at 2023-03-25T00:04:04-04:00 Modify ThreadId documentation and comments For a long time, `GHC.Conc.Sync` has said ```haskell -- ToDo: data ThreadId = ThreadId (Weak ThreadId#) -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. ``` We are now actually capable of using `Weak# ThreadId#`, but the world has moved on. To support the `Show` and `Ord` instances, we'd need to store the thread ID number in the `ThreadId`. And it seems very difficult to continue to support `threadStatus` in that regime, since it needs to be able to explain how threads died. In addition, garbage collection of weak references can be quite expensive, and it would be hard to evaluate the cost over he whole ecosystem. As discussed in [this CLC issue](https://github.com/haskell/core-libraries-committee/issues/125), it doesn't seem very likely that we'll actually switch to weak references here. - - - - - c421bbbb by Ben Gamari at 2023-03-25T00:04:41-04:00 rts: Fix barriers of IND and IND_STATIC Previously IND and IND_STATIC lacked the acquire barriers enjoyed by BLACKHOLE. As noted in the (now updated) Note [Heap memory barriers], this barrier is critical to ensure that the indirectee is visible to the entering core. Fixes #22872. - - - - - 62fa7faa by Bodigrim at 2023-03-25T00:05:22-04:00 Improve documentation of atomicModifyMutVar2# - - - - - b2d14d0b by Cheng Shao at 2023-03-25T03:46:43-04:00 rts: use performBlockingMajorGC in hs_perform_gc and fix ffi023 This patch does a few things: - Add the missing RtsSymbols.c entry of performBlockingMajorGC - Make hs_perform_gc call performBlockingMajorGC, which restores previous behavior - Use hs_perform_gc in ffi023 - Remove rts_clearMemory() call in ffi023, it now works again in some test ways previously marked as broken. Fixes #23089 - - - - - d9ae24ad by Cheng Shao at 2023-03-25T03:46:44-04:00 testsuite: add the rts_clearMemory test case This patch adds a standalone test case for rts_clearMemory that mimics how it's typically used by wasm backend users and ensures this RTS API isn't broken by future RTS refactorings. Fixes #23901. - - - - - 80729d96 by Bodigrim at 2023-03-25T03:47:22-04:00 Improve documentation for resizing of byte arrays - - - - - c6ec4cd1 by Ben Gamari at 2023-03-25T20:23:47-04:00 rts: Don't rely on EXTERN_INLINE for slop-zeroing logic Previously we relied on calling EXTERN_INLINE functions defined in ClosureMacros.h from Cmm to zero slop. However, as far as I can tell, this is no longer safe to do in C99 as EXTERN_INLINE definitions may be emitted in each compilation unit. Fix this by explicitly declaring a new set of non-inline functions in ZeroSlop.c which can be called from Cmm and marking the ClosureMacros.h definitions as INLINE_HEADER. In the future we should try to eliminate EXTERN_INLINE. - - - - - c32abd4b by Ben Gamari at 2023-03-25T20:23:48-04:00 rts: Fix capability-count check in zeroSlop Previously `zeroSlop` examined `RtsFlags` to determine whether the program was single-threaded. This is wrong; a program may be started with `+RTS -N1` yet the process may later increase the capability count with `setNumCapabilities`. This lead to quite subtle and rare crashes. Fixes #23088. - - - - - 656d4cb3 by Ryan Scott at 2023-03-25T20:24:23-04:00 Add Eq/Ord instances for SSymbol, SChar, and SNat This implements [CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148). - - - - - 4f93de88 by David Feuer at 2023-03-26T15:33:02-04:00 Update and expand atomic modification Haddocks * The documentation for `atomicModifyIORef` and `atomicModifyIORef'` were incomplete, and the documentation for `atomicModifyIORef` was out of date. Update and expand. * Remove a useless lazy pattern match in the definition of `atomicModifyIORef`. The pair it claims to match lazily was already forced by `atomicModifyIORef2`. - - - - - e1fb56b2 by David Feuer at 2023-03-26T15:33:41-04:00 Document the constructor name for lists Derived `Data` instances use raw infix constructor names when applicable. The `Data.Data [a]` instance, if derived, would have a constructor name of `":"`. However, it actually uses constructor name `"(:)"`. Document this peculiarity. See https://github.com/haskell/core-libraries-committee/issues/147 - - - - - c1f755c4 by Simon Peyton Jones at 2023-03-27T22:09:41+01:00 Make exprIsConApp_maybe a bit cleverer Addresses #23159. See Note Note [Exploit occ-info in exprIsConApp_maybe] in GHC.Core.SimpleOpt. Compile times go down very slightly, but always go down, never up. Good! Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -1.8% T15703(normal) -1.2% GOOD geo. mean -0.1% minimum -1.8% maximum +0.0% Metric Decrease: CoOpt_Singletons T15703 - - - - - 76bb4c58 by Ryan Scott at 2023-03-28T08:12:08-04:00 Add COMPLETE pragmas to TypeRep, SSymbol, SChar, and SNat This implements [CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149). - - - - - 89dae1c2 by Ben Gamari at 2023-03-29T14:00:27-04:00 base: Add test for #13660 - - - - - 4850ab82 by Ben Gamari at 2023-03-30T19:09:05-04:00 base: Move implementation of GHC.Foreign to GHC.Internal - - - - - 16826c77 by Ben Gamari at 2023-03-30T19:09:05-04:00 base: Introduce {new,with}CStringLen0 These are useful helpers for implementing the internal-NUL code unit check needed to fix #13660. - - - - - 6c7aa824 by Ben Gamari at 2023-03-30T19:09:05-04:00 base: Clean up documentation - - - - - 6625b5fc by Ben Gamari at 2023-03-30T19:09:05-04:00 base: Ensure that FilePaths don't contain NULs POSIX filepaths may not contain the NUL octet but previously we did not reject such paths. This could be exploited by untrusted input to cause discrepancies between various `FilePath` queries and the opened filename. For instance, `readFile "hello.so\x00.txt"` would open the file `"hello.so"` yet `takeFileExtension` would return `".txt"`. The same argument applies to Windows FilePaths Fixes #13660. - - - - - 30 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Driver/Config/Diagnostic.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/GHC/Utils/Error.hs - docs/users_guide/9.6.1-notes.rst - docs/users_guide/9.8.1-notes.rst - docs/users_guide/exts/pragmas.rst - docs/users_guide/using-warnings.rst - libraries/base/Data/Data.hs - libraries/base/Data/Functor/Compose.hs - libraries/base/Data/IORef.hs - libraries/base/Data/Typeable/Internal.hs - libraries/base/GHC/Conc/Sync.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b99477030a04d52962c816f188a5b4c82045c6a5...6625b5fc91b4771971826b4bc245a24e7fc2b245 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b99477030a04d52962c816f188a5b4c82045c6a5...6625b5fc91b4771971826b4bc245a24e7fc2b245 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 04:32:23 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 00:32:23 -0400 Subject: [Git][ghc/ghc][wip/ioref-swap-xchg] Update IORef.hs Message-ID: <6459ccd7dc79a_38ffda870d6344799034@gitlab.mail> Ben Gamari pushed to branch wip/ioref-swap-xchg at Glasgow Haskell Compiler / GHC Commits: ec9c1e8b by Ben Gamari at 2023-05-09T04:32:22+00:00 Update IORef.hs - - - - - 1 changed file: - libraries/base/GHC/IORef.hs Changes: ===================================== libraries/base/GHC/IORef.hs ===================================== @@ -127,7 +127,6 @@ atomicModifyIORef'_ ref f = do -- | Atomically replace the contents of an 'IORef', returning -- the old contents. atomicSwapIORef :: IORef a -> a -> IO a -atomicSwapIORef (IORef (STRef ref)) new = IO $ \s -> atomicSwapIORef (IORef (STRef ref)) new = IO (atomicSwapMutVar# ref new) -- | A strict version of 'Data.IORef.atomicModifyIORef'. This forces both the View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec9c1e8ba3e0f3d94b4caca5d72d7aca13f7aee4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec9c1e8ba3e0f3d94b4caca5d72d7aca13f7aee4 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 04:38:10 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 00:38:10 -0400 Subject: [Git][ghc/ghc][wip/exception-context] 3 commits: hi Message-ID: <6459ce324701_38ffda88242d58803620@gitlab.mail> Ben Gamari pushed to branch wip/exception-context at Glasgow Haskell Compiler / GHC Commits: 63735007 by Ben Gamari at 2023-05-08T17:17:16-04:00 hi - - - - - ec0a50b7 by Ben Gamari at 2023-05-08T19:18:53-04:00 CausedBy - - - - - c0b8a4f0 by Ben Gamari at 2023-05-09T00:24:18-04:00 NoCatch - - - - - 3 changed files: - libraries/base/GHC/Exception/Context.hs - libraries/base/GHC/Exception/Type.hs - libraries/base/GHC/IO.hs Changes: ===================================== libraries/base/GHC/Exception/Context.hs ===================================== @@ -64,7 +64,7 @@ addExceptionAnnotation x (ExceptionContext xs) = ExceptionContext (SomeException getExceptionAnnotations :: forall a. ExceptionAnnotation a => ExceptionContext -> [a] getExceptionAnnotations (ExceptionContext xs) = [ x - | SomeExceptionAnnotation (x :: b) <- xs + | SomeExceptionAnnotation (x :: b) <- xs , Just HRefl <- return (typeRep @a `eqTypeRep` typeRep @b) ] ===================================== libraries/base/GHC/Exception/Type.hs ===================================== @@ -32,6 +32,8 @@ module GHC.Exception.Type , emptyExceptionContext , mergeExceptionContext , ExceptionWithContext(..) + -- * CausedBy annotations + , CausedBy(..) -- * Arithmetic exceptions , ArithException(..) , divZeroException, overflowException, ratioZeroDenomException @@ -225,6 +227,15 @@ instance Exception a => Exception (ExceptionWithContext a) where backtraceDesired (ExceptionWithContext _ e) = backtraceDesired e displayException = displayException . toException +-- | An 'ExceptionAnnotation' which wraps the exception which +-- +-- @since 4.19.0.0 +newtype CausedBy = CausedBy SomeException + +instance ExceptionAnnotation CausedBy where + displayExceptionAnnotation (CausedBy e) = + "Caused by: " ++ displayException e + -- |Arithmetic exceptions. data ArithException = Overflow ===================================== libraries/base/GHC/IO.hs ===================================== @@ -161,6 +161,10 @@ catchException !io handler = catch io handler -- to catch exceptions of any type, see the section \"Catching all -- exceptions\" (in "Control.Exception") for an explanation of the problems with doing so. -- +-- If the exception handler throws an exception during execution, the +-- thrown exception will be annotated with a 'CausedBy' +-- 'ExceptionAnnotation'. +-- -- For catching exceptions in pure (non-'IO') expressions, see the -- function 'evaluate'. -- @@ -184,11 +188,24 @@ catch :: Exception e -> (e -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a -- See #exceptions_and_strictness#. -catch (IO io) handler = IO $ catch# io handler' +catch io handler = catchNoCause io (\e -> withCausedBy e (handler e)) + +-- | Catch an exception without adding a 'CausedBy' 'ExceptionContext' to any +-- exceptions thrown by the handler. See the documentation of 'catch' for a +-- detailed description of the semantics of this function. +-- +-- @since 4.19.0.0 +catchNoCause + :: Exception e + => IO a -- ^ The computation to run + -> (e -> IO a) -- ^ Handler to invoke if an exception is raised + -> IO a +-- See #exceptions_and_strictness#. +catchNoCause (IO io) handler = IO $ catch# io handler' where handler' e = case fromException e of - Just e' -> unIO (withAugmentedContext (exceptionContext e) (handler e')) + Just e' -> unIO (handler e') Nothing -> raiseIO# e -- | Catch any 'Exception' type in the 'IO' monad. @@ -200,12 +217,10 @@ catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a catchAny !(IO io) handler = IO $ catch# io handler' where handler' se@(SomeException e) = - unIO (withAugmentedContext (exceptionContext se) (handler e)) + unIO (withCausedBy se (handler e)) -withAugmentedContext :: ExceptionContext -> IO a -> IO a -withAugmentedContext ctxt (IO io) = IO (catch# io handler) - where - handler se = raiseIO# (augmentExceptionContext ctxt se) +withCausedBy :: SomeException -> IO a -> IO a +withCausedBy cause = annotateIO (CausedBy cause) -- | Execute an 'IO' action, adding the given 'ExceptionContext' -- to any thrown synchronous exceptions. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c39cf7827eb4f96ce27efa784440f19514abc919...c0b8a4f0294a420cf8e2bc9d1233ca2ae094022e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c39cf7827eb4f96ce27efa784440f19514abc919...c0b8a4f0294a420cf8e2bc9d1233ca2ae094022e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 05:46:27 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Tue, 09 May 2023 01:46:27 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/compact-sourcetext Message-ID: <6459de335c5b2_38ffda8ce833c08273d3@gitlab.mail> Zubin pushed new branch wip/compact-sourcetext at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/compact-sourcetext You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 06:46:46 2023 From: gitlab at gitlab.haskell.org (Bryan R (@chreekat)) Date: Tue, 09 May 2023 02:46:46 -0400 Subject: [Git][ghc/ghc] Pushed new branch wip/b/ghcup-metadata-nightly Message-ID: <6459ec561149e_38ffda8f573d90840333@gitlab.mail> Bryan R pushed new branch wip/b/ghcup-metadata-nightly at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/b/ghcup-metadata-nightly You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 08:44:37 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Tue, 09 May 2023 04:44:37 -0400 Subject: [Git][ghc/ghc][wip/compact-sourcetext] 3 commits: Use compact representation for SourceText Message-ID: <645a07f562196_38ffda97b7b8fc89849d@gitlab.mail> Zubin pushed to branch wip/compact-sourcetext at Glasgow Haskell Compiler / GHC Commits: c693827b by Zubin Duggal at 2023-05-09T14:14:29+05:30 Use compact representation for SourceText - - - - - 6d1880ec by Zubin Duggal at 2023-05-09T14:14:29+05:30 Use compact representation for SourceNotes - - - - - dbf2a234 by Zubin Duggal at 2023-05-09T14:14:29+05:30 Use compact representation for UsageFile (#22744) - - - - - 30 changed files: - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/Dwarf.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/IPE.hs - compiler/GHC/Types/SourceText.hs - compiler/GHC/Types/Tickish.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46c06c09d7a01638be00c5d8aa889a96cf798205...dbf2a234c5bf0361df39daafdb934441181720cb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46c06c09d7a01638be00c5d8aa889a96cf798205...dbf2a234c5bf0361df39daafdb934441181720cb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 09:03:50 2023 From: gitlab at gitlab.haskell.org (Bryan R (@chreekat)) Date: Tue, 09 May 2023 05:03:50 -0400 Subject: [Git][ghc/ghc][wip/b/ghcup-metadata-nightly] Fix up rules for ghcup-metadata-nightly-push Message-ID: <645a0c7612c4c_38ffda98a7f0b09076be@gitlab.mail> Bryan R pushed to branch wip/b/ghcup-metadata-nightly at Glasgow Haskell Compiler / GHC Commits: 0e2df4c9 by Bryan Richter at 2023-05-09T12:03:35+03:00 Fix up rules for ghcup-metadata-nightly-push - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1048,7 +1048,7 @@ ghcup-metadata-nightly: rules: - if: $NIGHTLY -# Update the +# Update the ghcup metadata with information about this nightly pipeline ghcup-metadata-nightly-push: stage: deploy image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" @@ -1072,11 +1072,8 @@ ghcup-metadata-nightly-push: - git commit -m "Update metadata" - git push gitlab_origin HEAD:updates -o ci.skip rules: - - if: $NIGHTLY # Only run the update on scheduled nightly pipelines, ie once a day - - if: $CI_PIPELINE_SOURCE == "schedule" - # And only update the metadata for master branch - - if: '$CI_COMMIT_BRANCH == "master"' + - if: $NIGHTLY && $CI_PIPELINE_SOURCE == "schedule" && $CI_COMMIT_BRANCH == "master" ghcup-metadata-release: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e2df4c9ac59a10080bd6e029e83a355ecd01c8b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e2df4c9ac59a10080bd6e029e83a355ecd01c8b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 09:47:51 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Tue, 09 May 2023 05:47:51 -0400 Subject: [Git][ghc/ghc][wip/dynamic-alpine] Build vanilla alpine bindists Message-ID: <645a16c78440c_38ffda9c5e41f0933540@gitlab.mail> Matthew Pickering pushed to branch wip/dynamic-alpine at Glasgow Haskell Compiler / GHC Commits: 17b70f2e by Matthew Pickering at 2023-05-09T10:47:40+01:00 Build vanilla alpine bindists We currently attempt to build and distribute fully static alpine bindists (ones which could be used on any linux platform) but most people who use the alpine bindists want to use alpine to build their own static applications (for which a fully static bindist is not necessary). We should build and distribute these bindists for these users whilst the fully-static bindist is still unusable. Fixes #23349 - - - - - 3 changed files: - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py Changes: ===================================== .gitlab/gen_ci.hs ===================================== @@ -424,7 +424,7 @@ distroVariables Alpine = mconcat -- T10458, ghcilink002: due to #17869 -- linker_unload_native: due to musl not supporting any means of probing dynlib dependencies -- (see Note [Object unloading]). - , "BROKEN_TESTS" =: "encoding004 T10458 ghcilink002 linker_unload_native" + , "BROKEN_TESTS" =: "encoding004 T10458 linker_unload_native" ] distroVariables Centos7 = mconcat [ "HADRIAN_ARGS" =: "--docs=no-sphinx" @@ -903,8 +903,11 @@ job_groups = , standardBuildsWithConfig AArch64 (Linux Debian10) (splitSectionsBroken vanilla) , disableValidate (validateBuilds AArch64 (Linux Debian10) llvm) , standardBuildsWithConfig I386 (Linux Debian9) (splitSectionsBroken vanilla) - , standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken static) - , disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt)) + -- Fully static build, in theory usable on any linux distribution. + , fullyStaticBrokenTests (standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken static)) + -- Dynamically linked build, suitable for building your own static executables on alpine + , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken vanilla)) + , fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt))) , validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing) , validateBuilds Amd64 (Linux Debian11) (crossConfig "javascript-unknown-ghcjs" (Emulator "js-emulator") (Just "emconfigure") ) @@ -919,6 +922,10 @@ job_groups = ] where + + -- ghcilink002 broken due to #17869 + fullyStaticBrokenTests = modifyJobs (addVariable "BROKEN_TESTS" "ghcilink002 ") + hackage_doc_job = rename (<> "-hackage") . modifyJobs (addVariable "HADRIAN_ARGS" "--haddock-base-url") tsan_jobs = ===================================== .gitlab/jobs.yaml ===================================== @@ -597,7 +597,7 @@ "variables": { "BIGNUM_BACKEND": "native", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-int_native-validate+fully_static", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "validate+fully_static", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--docs=no-sphinx", @@ -606,6 +606,68 @@ "XZ_OPT": "-9" } }, + "nightly-x86_64-linux-alpine3_12-validate": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh clean", + "cat ci_timings" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "8 weeks", + "paths": [ + "ghc-x86_64-linux-alpine3_12-validate.tar.xz", + "junit.xml" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-alpine3_12-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate", + "BROKEN_TESTS": "encoding004 T10458 linker_unload_native", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--disable-ld-override ", + "HADRIAN_ARGS": "--docs=no-sphinx", + "INSTALL_CONFIGURE_ARGS": "--disable-ld-override", + "TEST_ENV": "x86_64-linux-alpine3_12-validate", + "XZ_OPT": "-9" + } + }, "nightly-x86_64-linux-alpine3_12-validate+fully_static": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -659,7 +721,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate+fully_static", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "validate+fully_static", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--docs=no-sphinx", @@ -2472,7 +2534,7 @@ "variables": { "BIGNUM_BACKEND": "native", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-int_native-release+fully_static", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "release+fully_static", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--hash-unit-ids --docs=no-sphinx", @@ -2535,7 +2597,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-release+fully_static+no_split_sections", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "release+fully_static+no_split_sections", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--hash-unit-ids --docs=no-sphinx", @@ -2545,6 +2607,69 @@ "XZ_OPT": "-9" } }, + "release-x86_64-linux-alpine3_12-release+no_split_sections": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh clean", + "cat ci_timings" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "1 year", + "paths": [ + "ghc-x86_64-linux-alpine3_12-release+no_split_sections.tar.xz", + "junit.xml" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-alpine3_12-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "gmp", + "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-release+no_split_sections", + "BROKEN_TESTS": "encoding004 T10458 linker_unload_native", + "BUILD_FLAVOUR": "release+no_split_sections", + "CONFIGURE_ARGS": "--disable-ld-override ", + "HADRIAN_ARGS": "--hash-unit-ids --docs=no-sphinx", + "IGNORE_PERF_FAILURES": "all", + "INSTALL_CONFIGURE_ARGS": "--disable-ld-override", + "TEST_ENV": "x86_64-linux-alpine3_12-release+no_split_sections", + "XZ_OPT": "-9" + } + }, "release-x86_64-linux-centos7-release+no_split_sections": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -3581,7 +3706,7 @@ "variables": { "BIGNUM_BACKEND": "gmp", "BIN_DIST_NAME": "ghc-x86_64-linux-alpine3_12-validate+fully_static", - "BROKEN_TESTS": "encoding004 T10458 ghcilink002 linker_unload_native", + "BROKEN_TESTS": "ghcilink002 encoding004 T10458 linker_unload_native", "BUILD_FLAVOUR": "validate+fully_static", "CONFIGURE_ARGS": "--disable-ld-override ", "HADRIAN_ARGS": "--docs=no-sphinx", ===================================== .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py ===================================== @@ -30,6 +30,7 @@ def job_triple(job_name): 'release-x86_64-linux-deb9-release': 'x86_64-deb9-linux', 'release-x86_64-linux-centos7-release': 'x86_64-centos7-linux', 'release-x86_64-linux-alpine3_12-release+fully_static': 'x86_64-alpine3_12-linux-static', + 'release-x86_64-linux-alpine3_12-release': 'x86_64-alpine3_12-linux', 'release-x86_64-linux-alpine3_12-int_native-release+fully_static': 'x86_64-alpine3_12-linux-static-int_native', 'release-x86_64-darwin-release': 'x86_64-apple-darwin', 'release-i386-linux-deb9-release': 'i386-deb9-linux', View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/17b70f2ecebaa2506da949f07327a98654627cdb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/17b70f2ecebaa2506da949f07327a98654627cdb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 11:21:27 2023 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Tue, 09 May 2023 07:21:27 -0400 Subject: [Git][ghc/ghc][wip/unboxed-codebuffer] Use unboxed codebuffers in base Message-ID: <645a2cb72ca6_38ffdaa1f2bcf4964469@gitlab.mail> Josh Meredith pushed to branch wip/unboxed-codebuffer at Glasgow Haskell Compiler / GHC Commits: 536e0538 by Josh Meredith at 2023-05-09T11:19:39+00:00 Use unboxed codebuffers in base Metric Decrease: encodingAllocations - - - - - 8 changed files: - libraries/base/GHC/IO/Encoding.hs - libraries/base/GHC/IO/Encoding/CodePage/API.hs - libraries/base/GHC/IO/Encoding/Failure.hs - libraries/base/GHC/IO/Encoding/Iconv.hs - libraries/base/GHC/IO/Encoding/Latin1.hs - libraries/base/GHC/IO/Encoding/UTF16.hs - libraries/base/GHC/IO/Encoding/UTF32.hs - libraries/base/GHC/IO/Encoding/UTF8.hs Changes: ===================================== libraries/base/GHC/IO/Encoding.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- @@ -336,11 +337,13 @@ mkTextEncoding' cfm enc = latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8) -latin1_encode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_encode input output -- unchecked, used for char8 +latin1_encode input output = IO $ \st -> case Latin1.latin1_encode input output st of + (# st', _why, input', output' #) -> (# st', (input', output') #) -- unchecked, used for char8 --latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer) -latin1_decode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_decode input output +latin1_decode input output = IO $ \st -> case Latin1.latin1_decode input output st of + (# st', _why, input', output' #) -> (# st', (input',output') #) --latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode unknownEncodingErr :: String -> IO a ===================================== libraries/base/GHC/IO/Encoding/CodePage/API.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, NondecreasingIndentation, - RecordWildCards, ScopedTypeVariables #-} + RecordWildCards, ScopedTypeVariables, + UnboxedTuples #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module GHC.IO.Encoding.CodePage.API ( @@ -157,11 +158,15 @@ newCP rec fn cp = do utf16_native_encode' :: EncodeBuffer utf16_native_decode' :: DecodeBuffer #if defined(WORDS_BIGENDIAN) -utf16_native_encode' = utf16be_encode -utf16_native_decode' = utf16be_decode +utf16_native_encode' i o = IO $ \st -> case utf16be_encode i o st of + (# st', c, i', o' #) -> (# st', (c, i', o') #) +utf16_native_decode' i o = IO $ \st -> case utf16be_decode i o st of + (# st', c, i', o' #) -> (# st', (c, i', o') #) #else -utf16_native_encode' = utf16le_encode -utf16_native_decode' = utf16le_decode +utf16_native_encode' i o = IO $ \st -> case utf16le_encode i o st of + (# st', c, i', o' #) -> (# st', (c, i', o') #) +utf16_native_decode' i o = IO $ \st -> case utf16le_decode i o st of + (# st', c, i', o' #) -> (# st', (c, i', o') #) #endif saner :: CodeBuffer from to ===================================== libraries/base/GHC/IO/Encoding/Failure.hs ===================================== @@ -1,5 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -18,7 +21,8 @@ module GHC.IO.Encoding.Failure ( CodingFailureMode(..), codingFailureModeSuffix, isSurrogate, - recoverDecode, recoverEncode + recoverDecode, recoverEncode, + recoverDecode#, recoverEncode#, ) where import GHC.IO @@ -142,6 +146,12 @@ unescapeRoundtripCharacterSurrogate c | otherwise = Nothing where x = ord c +recoverDecode# :: CodingFailureMode -> Buffer Word8 -> Buffer Char + -> State# RealWorld -> (# State# RealWorld, Buffer Word8, Buffer Char #) +recoverDecode# cfm input output st = + let !(# st', (bIn, bOut) #) = unIO (recoverDecode cfm input output) st + in (# st', bIn, bOut #) + recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char) recoverDecode cfm input at Buffer{ bufRaw=iraw, bufL=ir, bufR=_ } @@ -160,6 +170,12 @@ recoverDecode cfm input at Buffer{ bufRaw=iraw, bufL=ir, bufR=_ } ow' <- writeCharBuf oraw ow (escapeToRoundtripCharacterSurrogate b) return (input { bufL=ir+1 }, output { bufR=ow' }) +recoverEncode# :: CodingFailureMode -> Buffer Char -> Buffer Word8 + -> State# RealWorld -> (# State# RealWorld, Buffer Char, Buffer Word8 #) +recoverEncode# cfm input output st = + let !(# st', (bIn, bOut) #) = unIO (recoverEncode cfm input output) st + in (# st', bIn, bOut #) + recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8) recoverEncode cfm input at Buffer{ bufRaw=iraw, bufL=ir, bufR=_ } ===================================== libraries/base/GHC/IO/Encoding/Iconv.hs ===================================== @@ -2,6 +2,8 @@ {-# LANGUAGE CPP , NoImplicitPrelude , NondecreasingIndentation + , UnboxedTuples + , MagicHash #-} {-# OPTIONS_HADDOCK not-home #-} @@ -133,19 +135,24 @@ newIConv from to rec fn = withCAString to $ \ to_str -> do iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ hs_iconv_open to_str from_str let iclose = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt - return BufferCodec{ - encode = fn iconvt, - recover = rec, - close = iclose, + fn_iconvt ibuf obuf st = case unIO (fn iconvt ibuf obuf) st of + (# st', (prog, ibuf', obuf') #) -> (# st', prog, ibuf', obuf' #) + return BufferCodec# { + encode# = fn_iconvt, + recover# = rec#, + close# = iclose, -- iconv doesn't supply a way to save/restore the state - getState = return (), - setState = const $ return () + getState# = return (), + setState# = const $ return () } + where + rec# ibuf obuf st = case unIO (rec ibuf obuf) st of + (# st', (ibuf', obuf') #) -> (# st', ibuf', obuf' #) -iconvDecode :: IConv -> DecodeBuffer +iconvDecode :: IConv -> Buffer Word8 -> Buffer Char -> IO (CodingProgress, Buffer Word8, Buffer Char) iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift -iconvEncode :: IConv -> EncodeBuffer +iconvEncode :: IConv -> Buffer Char -> Buffer Word8 -> IO (CodingProgress, Buffer Char, Buffer Word8) iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0 iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int ===================================== libraries/base/GHC/IO/Encoding/Latin1.hs ===================================== @@ -2,6 +2,8 @@ {-# LANGUAGE NoImplicitPrelude , BangPatterns , NondecreasingIndentation + , UnboxedTuples + , MagicHash #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -56,22 +58,22 @@ mkLatin1 cfm = TextEncoding { textEncodingName = "ISO-8859-1", latin1_DF :: CodingFailureMode -> IO (TextDecoder ()) latin1_DF cfm = - return (BufferCodec { - encode = latin1_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = latin1_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) latin1_EF :: CodingFailureMode -> IO (TextEncoder ()) latin1_EF cfm = - return (BufferCodec { - encode = latin1_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = latin1_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) latin1_checked :: TextEncoding @@ -85,12 +87,12 @@ mkLatin1_checked cfm = TextEncoding { textEncodingName = "ISO-8859-1", latin1_checked_EF :: CodingFailureMode -> IO (TextEncoder ()) latin1_checked_EF cfm = - return (BufferCodec { - encode = latin1_checked_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = latin1_checked_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) -- ----------------------------------------------------------------------------- @@ -108,22 +110,22 @@ mkAscii cfm = TextEncoding { textEncodingName = "ASCII", ascii_DF :: CodingFailureMode -> IO (TextDecoder ()) ascii_DF cfm = - return (BufferCodec { - encode = ascii_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = ascii_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) ascii_EF :: CodingFailureMode -> IO (TextEncoder ()) ascii_EF cfm = - return (BufferCodec { - encode = ascii_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = ascii_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) @@ -134,97 +136,115 @@ ascii_EF cfm = -- TODO: Eliminate code duplication between the checked and unchecked -- versions of the decoder or encoder (but don't change the Core!) -latin1_decode :: DecodeBuffer +latin1_decode :: DecodeBuffer# latin1_decode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) - loop (ir+1) ow' + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir) st0 + !(# st2, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral c0))) st1 + loop (ir+1) ow' st2 -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -ascii_decode :: DecodeBuffer +ascii_decode :: DecodeBuffer# ascii_decode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - if c0 > 0x7f then invalid else do - ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) - loop (ir+1) ow' + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir) st0 + if c0 > 0x7f then invalid st1 else do + let !(# st2, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral c0))) st1 + loop (ir+1) ow' st2 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -latin1_encode :: EncodeBuffer +latin1_encode :: EncodeBuffer# latin1_encode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir - writeWord8Buf oraw ow (fromIntegral (ord c)) - loop ir' (ow+1) + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 + !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral (ord c))) st1 + loop ir' (ow+1) st2 in - loop ir0 ow0 + loop ir0 ow0 st -latin1_checked_encode :: EncodeBuffer +latin1_checked_encode :: EncodeBuffer# latin1_checked_encode input output = single_byte_checked_encode 0xff input output -ascii_encode :: EncodeBuffer +ascii_encode :: EncodeBuffer# ascii_encode input output = single_byte_checked_encode 0x7f input output -single_byte_checked_encode :: Int -> EncodeBuffer +single_byte_checked_encode :: Int -> EncodeBuffer# single_byte_checked_encode max_legal_char input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir - if ord c > max_legal_char then invalid else do - writeWord8Buf oraw ow (fromIntegral (ord c)) - loop ir' (ow+1) + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 + if ord c > max_legal_char then invalid st1 else do + let !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral (ord c))) st1 + loop ir' (ow+1) st2 where - invalid = done InvalidSequence ir ow + invalid :: EncodingBuffer# + invalid st' = done InvalidSequence ir ow st' in - loop ir0 ow0 + loop ir0 ow0 st {-# INLINE single_byte_checked_encode #-} ===================================== libraries/base/GHC/IO/Encoding/UTF16.hs ===================================== @@ -3,6 +3,7 @@ , BangPatterns , NondecreasingIndentation , MagicHash + , UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -61,64 +62,66 @@ mkUTF16 cfm = TextEncoding { textEncodingName = "UTF-16", mkTextDecoder = utf16_DF cfm, mkTextEncoder = utf16_EF cfm } -utf16_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer)) +utf16_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer#)) utf16_DF cfm = do seen_bom <- newIORef Nothing - return (BufferCodec { - encode = utf16_decode seen_bom, - recover = recoverDecode cfm, - close = return (), - getState = readIORef seen_bom, - setState = writeIORef seen_bom + return (BufferCodec# { + encode# = utf16_decode seen_bom, + recover# = recoverDecode# cfm, + close# = return (), + getState# = readIORef seen_bom, + setState# = writeIORef seen_bom }) utf16_EF :: CodingFailureMode -> IO (TextEncoder Bool) utf16_EF cfm = do done_bom <- newIORef False - return (BufferCodec { - encode = utf16_encode done_bom, - recover = recoverEncode cfm, - close = return (), - getState = readIORef done_bom, - setState = writeIORef done_bom + return (BufferCodec# { + encode# = utf16_encode done_bom, + recover# = recoverEncode# cfm, + close# = return (), + getState# = readIORef done_bom, + setState# = writeIORef done_bom }) -utf16_encode :: IORef Bool -> EncodeBuffer +utf16_encode :: IORef Bool -> EncodeBuffer# utf16_encode done_bom input output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + st0 = do - b <- readIORef done_bom - if b then utf16_native_encode input output + let !(# st1, b #) = unIO (readIORef done_bom) st0 + if b then utf16_native_encode input output st1 else if os - ow < 2 - then return (OutputUnderflow,input,output) + then (# st1,OutputUnderflow,input,output #) else do - writeIORef done_bom True - writeWord8Buf oraw ow bom1 - writeWord8Buf oraw (ow+1) bom2 - utf16_native_encode input output{ bufR = ow+2 } + let !(# st2, () #) = unIO (writeIORef done_bom True) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw ow bom1) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+1) bom2) st3 + utf16_native_encode input output{ bufR = ow+2 } st4 -utf16_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer +utf16_decode :: IORef (Maybe DecodeBuffer#) -> DecodeBuffer# utf16_decode seen_bom input at Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } output + st0 = do - mb <- readIORef seen_bom + let !(# st1, mb #) = unIO (readIORef seen_bom) st0 case mb of - Just decode -> decode input output + Just decode -> decode input output st1 Nothing -> - if iw - ir < 2 then return (InputUnderflow,input,output) else do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) + if iw - ir < 2 then (# st1,InputUnderflow,input,output #) else do + let !(# st2, c0 #) = unIO (readWord8Buf iraw ir ) st1 + !(# st3, c1 #) = unIO (readWord8Buf iraw (ir+1)) st2 case () of - _ | c0 == bomB && c1 == bomL -> do - writeIORef seen_bom (Just utf16be_decode) - utf16be_decode input{ bufL= ir+2 } output - | c0 == bomL && c1 == bomB -> do - writeIORef seen_bom (Just utf16le_decode) - utf16le_decode input{ bufL= ir+2 } output - | otherwise -> do - writeIORef seen_bom (Just utf16_native_decode) - utf16_native_decode input output + _ | c0 == bomB && c1 == bomL -> + let !(# st4, () #) = unIO (writeIORef seen_bom (Just utf16be_decode)) st3 + in utf16be_decode input{ bufL= ir+2 } output st4 + | c0 == bomL && c1 == bomB -> + let !(# st4, () #) = unIO (writeIORef seen_bom (Just utf16le_decode)) st3 + in utf16le_decode input{ bufL= ir+2 } output st4 + | otherwise -> + let !(# st4, () #) = unIO (writeIORef seen_bom (Just utf16_native_decode)) st3 + in utf16_native_decode input output st4 bomB, bomL, bom1, bom2 :: Word8 @@ -126,10 +129,10 @@ bomB = 0xfe bomL = 0xff -- choose UTF-16BE by default for UTF-16 output -utf16_native_decode :: DecodeBuffer +utf16_native_decode :: DecodeBuffer# utf16_native_decode = utf16be_decode -utf16_native_encode :: EncodeBuffer +utf16_native_encode :: EncodeBuffer# utf16_native_encode = utf16be_encode bom1 = bomB @@ -149,22 +152,22 @@ mkUTF16be cfm = TextEncoding { textEncodingName = "UTF-16BE", utf16be_DF :: CodingFailureMode -> IO (TextDecoder ()) utf16be_DF cfm = - return (BufferCodec { - encode = utf16be_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf16be_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf16be_EF :: CodingFailureMode -> IO (TextEncoder ()) utf16be_EF cfm = - return (BufferCodec { - encode = utf16be_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf16be_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf16le :: TextEncoding @@ -178,114 +181,127 @@ mkUTF16le cfm = TextEncoding { textEncodingName = "UTF16-LE", utf16le_DF :: CodingFailureMode -> IO (TextDecoder ()) utf16le_DF cfm = - return (BufferCodec { - encode = utf16le_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf16le_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf16le_EF :: CodingFailureMode -> IO (TextEncoder ()) utf16le_EF cfm = - return (BufferCodec { - encode = utf16le_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf16le_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) -utf16be_decode :: DecodeBuffer +utf16be_decode :: DecodeBuffer# utf16be_decode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow - | ir + 1 == iw = done InputUnderflow ir ow + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | ir + 1 == iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir ) st0 + !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 let x1 = fromIntegral c0 `shiftL` 8 + fromIntegral c1 if validate1 x1 - then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) - loop (ir+2) ow' - else if iw - ir < 4 then done InputUnderflow ir ow else do - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) - let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3 - if not (validate2 x1 x2) then invalid else do - ow' <- writeCharBuf oraw ow (chr2 x1 x2) - loop (ir+4) ow' + then let !(# st3, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral x1))) st2 + in loop (ir+2) ow' st3 + else if iw - ir < 4 then done InputUnderflow ir ow st2 else do + let !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 + x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3 + if not (validate2 x1 x2) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow (chr2 x1 x2)) st4 + loop (ir+4) ow' st5 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input { bufL = 0, bufR = 0 } else input { bufL = ir } + !ro = output{ bufR = ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf16le_decode :: DecodeBuffer +utf16le_decode :: DecodeBuffer# utf16le_decode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow - | ir + 1 == iw = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | ir + 1 == iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0 + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir ) st0 + !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0 if validate1 x1 - then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) - loop (ir+2) ow' - else if iw - ir < 4 then done InputUnderflow ir ow else do - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) - let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2 - if not (validate2 x1 x2) then invalid else do - ow' <- writeCharBuf oraw ow (chr2 x1 x2) - loop (ir+4) ow' + then let !(# st3, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral x1))) st2 + in loop (ir+2) ow' st3 + else if iw - ir < 4 then done InputUnderflow ir ow st2 else do + let !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 + x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2 + if not (validate2 x1 x2) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow (chr2 x1 x2)) st4 + loop (ir+4) ow' st5 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0 } else input{ bufL = ir } + !ro = output{ bufR = ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf16be_encode :: EncodeBuffer +utf16be_encode :: EncodeBuffer# utf16be_encode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 2 = done OutputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | os - ow < 2 = done OutputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 case ord c of - x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do - writeWord8Buf oraw ow (fromIntegral (x `shiftR` 8)) - writeWord8Buf oraw (ow+1) (fromIntegral x) - loop ir' (ow+2) + x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow st1 else do + let !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral (x `shiftR` 8))) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) (fromIntegral x)) st2 + loop ir' (ow+2) st3 | otherwise -> do - if os - ow < 4 then done OutputUnderflow ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow st1 else do let n1 = x - 0x10000 c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) @@ -294,35 +310,39 @@ utf16be_encode c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) c4 = fromIntegral n2 -- - writeWord8Buf oraw ow c1 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c3 - writeWord8Buf oraw (ow+3) c4 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c1) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c3) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c4) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st -utf16le_encode :: EncodeBuffer +utf16le_encode :: EncodeBuffer# utf16le_encode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 2 = done OutputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0 } else input{ bufL = ir } + !ro = output{ bufR = ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | os - ow < 2 = done OutputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 case ord c of - x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do - writeWord8Buf oraw ow (fromIntegral x) - writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8)) - loop ir' (ow+2) + x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow st1 else do + let !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral x)) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8))) st2 + loop ir' (ow+2) st3 | otherwise -> - if os - ow < 4 then done OutputUnderflow ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow st1 else do let n1 = x - 0x10000 c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) @@ -331,13 +351,13 @@ utf16le_encode c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) c4 = fromIntegral n2 -- - writeWord8Buf oraw ow c2 - writeWord8Buf oraw (ow+1) c1 - writeWord8Buf oraw (ow+2) c4 - writeWord8Buf oraw (ow+3) c3 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c2) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c1) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c4) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c3) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st chr2 :: Word16 -> Word16 -> Char chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#)) ===================================== libraries/base/GHC/IO/Encoding/UTF32.hs ===================================== @@ -3,6 +3,7 @@ , BangPatterns , NondecreasingIndentation , MagicHash + , UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -61,68 +62,70 @@ mkUTF32 cfm = TextEncoding { textEncodingName = "UTF-32", mkTextDecoder = utf32_DF cfm, mkTextEncoder = utf32_EF cfm } -utf32_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer)) +utf32_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer#)) utf32_DF cfm = do seen_bom <- newIORef Nothing - return (BufferCodec { - encode = utf32_decode seen_bom, - recover = recoverDecode cfm, - close = return (), - getState = readIORef seen_bom, - setState = writeIORef seen_bom + return (BufferCodec# { + encode# = utf32_decode seen_bom, + recover# = recoverDecode# cfm, + close# = return (), + getState# = readIORef seen_bom, + setState# = writeIORef seen_bom }) utf32_EF :: CodingFailureMode -> IO (TextEncoder Bool) utf32_EF cfm = do done_bom <- newIORef False - return (BufferCodec { - encode = utf32_encode done_bom, - recover = recoverEncode cfm, - close = return (), - getState = readIORef done_bom, - setState = writeIORef done_bom + return (BufferCodec# { + encode# = utf32_encode done_bom, + recover# = recoverEncode# cfm, + close# = return (), + getState# = readIORef done_bom, + setState# = writeIORef done_bom }) -utf32_encode :: IORef Bool -> EncodeBuffer +utf32_encode :: IORef Bool -> EncodeBuffer# utf32_encode done_bom input output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + st0 = do - b <- readIORef done_bom - if b then utf32_native_encode input output + let !(# st1, b #) = unIO (readIORef done_bom) st0 + if b then utf32_native_encode input output st1 else if os - ow < 4 - then return (OutputUnderflow, input,output) + then (# st1,OutputUnderflow,input,output #) else do - writeIORef done_bom True - writeWord8Buf oraw ow bom0 - writeWord8Buf oraw (ow+1) bom1 - writeWord8Buf oraw (ow+2) bom2 - writeWord8Buf oraw (ow+3) bom3 - utf32_native_encode input output{ bufR = ow+4 } - -utf32_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer + let !(# st2, () #) = unIO (writeIORef done_bom True) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw ow bom0) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+1) bom1) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+2) bom2) st4 + !(# st6, () #) = unIO (writeWord8Buf oraw (ow+3) bom3) st5 + utf32_native_encode input output{ bufR = ow+4 } st6 + +utf32_decode :: IORef (Maybe DecodeBuffer#) -> DecodeBuffer# utf32_decode seen_bom input at Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } output + st0 = do - mb <- readIORef seen_bom + let !(# st1, mb #) = unIO (readIORef seen_bom) st0 case mb of - Just decode -> decode input output + Just decode -> decode input output st1 Nothing -> - if iw - ir < 4 then return (InputUnderflow, input,output) else do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) + if iw - ir < 4 then (# st1,InputUnderflow,input,output #) else do + let !(# st2, c0 #) = unIO (readWord8Buf iraw ir ) st1 + !(# st3, c1 #) = unIO (readWord8Buf iraw (ir+1)) st2 + !(# st4, c2 #) = unIO (readWord8Buf iraw (ir+2)) st3 + !(# st5, c3 #) = unIO (readWord8Buf iraw (ir+3)) st4 case () of - _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> do - writeIORef seen_bom (Just utf32be_decode) - utf32be_decode input{ bufL= ir+4 } output - _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> do - writeIORef seen_bom (Just utf32le_decode) - utf32le_decode input{ bufL= ir+4 } output - | otherwise -> do - writeIORef seen_bom (Just utf32_native_decode) - utf32_native_decode input output + _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> + let !(# st6, () #) = unIO (writeIORef seen_bom (Just utf32be_decode)) st5 + in utf32be_decode input{ bufL= ir+4 } output st6 + _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> + let !(# st6, () #) = unIO (writeIORef seen_bom (Just utf32le_decode)) st5 + in utf32le_decode input{ bufL= ir+4 } output st6 + | otherwise -> + let !(# st6, () #) = unIO (writeIORef seen_bom (Just utf32_native_decode)) st5 + in utf32_native_decode input output st6 bom0, bom1, bom2, bom3 :: Word8 @@ -132,10 +135,10 @@ bom2 = 0xfe bom3 = 0xff -- choose UTF-32BE by default for UTF-32 output -utf32_native_decode :: DecodeBuffer +utf32_native_decode :: DecodeBuffer# utf32_native_decode = utf32be_decode -utf32_native_encode :: EncodeBuffer +utf32_native_encode :: EncodeBuffer# utf32_native_encode = utf32be_encode -- ----------------------------------------------------------------------------- @@ -152,22 +155,22 @@ mkUTF32be cfm = TextEncoding { textEncodingName = "UTF-32BE", utf32be_DF :: CodingFailureMode -> IO (TextDecoder ()) utf32be_DF cfm = - return (BufferCodec { - encode = utf32be_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf32be_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf32be_EF :: CodingFailureMode -> IO (TextEncoder ()) utf32be_EF cfm = - return (BufferCodec { - encode = utf32be_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf32be_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) @@ -182,128 +185,145 @@ mkUTF32le cfm = TextEncoding { textEncodingName = "UTF-32LE", utf32le_DF :: CodingFailureMode -> IO (TextDecoder ()) utf32le_DF cfm = - return (BufferCodec { - encode = utf32le_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf32le_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf32le_EF :: CodingFailureMode -> IO (TextEncoder ()) utf32le_EF cfm = - return (BufferCodec { - encode = utf32le_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf32le_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) -utf32be_decode :: DecodeBuffer +utf32be_decode :: DecodeBuffer# utf32be_decode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | iw - ir < 4 = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | iw - ir < 4 = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir ) st0 + !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 let x1 = chr4 c0 c1 c2 c3 - if not (validate x1) then invalid else do - ow' <- writeCharBuf oraw ow x1 - loop (ir+4) ow' + if not (validate x1) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow x1) st4 + loop (ir+4) ow' st5 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf32le_decode :: DecodeBuffer +utf32le_decode :: DecodeBuffer# utf32le_decode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | iw - ir < 4 = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | iw - ir < 4 = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir ) st0 + !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 let x1 = chr4 c3 c2 c1 c0 - if not (validate x1) then invalid else do - ow' <- writeCharBuf oraw ow x1 - loop (ir+4) ow' + if not (validate x1) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow x1) st4 + loop (ir+4) ow' st5 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf32be_encode :: EncodeBuffer +utf32be_encode :: EncodeBuffer# utf32be_encode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 4 = done OutputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | os - ow < 4 = done OutputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir - if isSurrogate c then done InvalidSequence ir ow else do + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 + if isSurrogate c then done InvalidSequence ir ow st1 else do let (c0,c1,c2,c3) = ord4 c - writeWord8Buf oraw ow c0 - writeWord8Buf oraw (ow+1) c1 - writeWord8Buf oraw (ow+2) c2 - writeWord8Buf oraw (ow+3) c3 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c0) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c1) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c2) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c3) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st -utf32le_encode :: EncodeBuffer +utf32le_encode :: EncodeBuffer# utf32le_encode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ir >= iw = done InputUnderflow ir ow - | os - ow < 4 = done OutputUnderflow ir ow + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir } + !ro = output{ bufR=ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ir >= iw = done InputUnderflow ir ow st0 + | os - ow < 4 = done OutputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir - if isSurrogate c then done InvalidSequence ir ow else do + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 + if isSurrogate c then done InvalidSequence ir ow st1 else do let (c0,c1,c2,c3) = ord4 c - writeWord8Buf oraw ow c3 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c1 - writeWord8Buf oraw (ow+3) c0 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c3) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c1) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c0) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = ===================================== libraries/base/GHC/IO/Encoding/UTF8.hs ===================================== @@ -3,6 +3,7 @@ , BangPatterns , NondecreasingIndentation , MagicHash + , UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -56,22 +57,22 @@ mkUTF8 cfm = TextEncoding { textEncodingName = "UTF-8", utf8_DF :: CodingFailureMode -> IO (TextDecoder ()) utf8_DF cfm = - return (BufferCodec { - encode = utf8_decode, - recover = recoverDecode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf8_decode, + recover# = recoverDecode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf8_EF :: CodingFailureMode -> IO (TextEncoder ()) utf8_EF cfm = - return (BufferCodec { - encode = utf8_encode, - recover = recoverEncode cfm, - close = return (), - getState = return (), - setState = const $ return () + return (BufferCodec# { + encode# = utf8_encode, + recover# = recoverEncode# cfm, + close# = return (), + getState# = return (), + setState# = const $ return () }) utf8_bom :: TextEncoding @@ -85,177 +86,188 @@ mkUTF8_bom cfm = TextEncoding { textEncodingName = "UTF-8BOM", utf8_bom_DF :: CodingFailureMode -> IO (TextDecoder Bool) utf8_bom_DF cfm = do ref <- newIORef True - return (BufferCodec { - encode = utf8_bom_decode ref, - recover = recoverDecode cfm, - close = return (), - getState = readIORef ref, - setState = writeIORef ref + return (BufferCodec# { + encode# = utf8_bom_decode ref, + recover# = recoverDecode# cfm, + close# = return (), + getState# = readIORef ref, + setState# = writeIORef ref }) utf8_bom_EF :: CodingFailureMode -> IO (TextEncoder Bool) utf8_bom_EF cfm = do ref <- newIORef True - return (BufferCodec { - encode = utf8_bom_encode ref, - recover = recoverEncode cfm, - close = return (), - getState = readIORef ref, - setState = writeIORef ref + return (BufferCodec# { + encode# = utf8_bom_encode ref, + recover# = recoverEncode# cfm, + close# = return (), + getState# = readIORef ref, + setState# = writeIORef ref }) -utf8_bom_decode :: IORef Bool -> DecodeBuffer +utf8_bom_decode :: IORef Bool -> DecodeBuffer# utf8_bom_decode ref input at Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } output + st0 = do - first <- readIORef ref + let !(# st1, first #) = unIO (readIORef ref) st0 if not first - then utf8_decode input output + then utf8_decode input output st1 else do - let no_bom = do writeIORef ref False; utf8_decode input output - if iw - ir < 1 then return (InputUnderflow,input,output) else do - c0 <- readWord8Buf iraw ir + let no_bom = let !(# st', () #) = unIO (writeIORef ref False) st1 in utf8_decode input output st' + if iw - ir < 1 then (# st1,InputUnderflow,input,output #) else do + let !(# st2, c0 #) = unIO (readWord8Buf iraw ir) st1 if (c0 /= bom0) then no_bom else do - if iw - ir < 2 then return (InputUnderflow,input,output) else do - c1 <- readWord8Buf iraw (ir+1) + if iw - ir < 2 then (# st2,InputUnderflow,input,output #) else do + let !(# st3, c1 #) = unIO (readWord8Buf iraw (ir+1)) st2 if (c1 /= bom1) then no_bom else do - if iw - ir < 3 then return (InputUnderflow,input,output) else do - c2 <- readWord8Buf iraw (ir+2) + if iw - ir < 3 then (# st3,InputUnderflow,input,output #) else do + let !(# st4, c2 #) = unIO (readWord8Buf iraw (ir+2)) st3 if (c2 /= bom2) then no_bom else do -- found a BOM, ignore it and carry on - writeIORef ref False - utf8_decode input{ bufL = ir + 3 } output + let !(# st5, () #) = unIO (writeIORef ref False) st4 + utf8_decode input{ bufL = ir + 3 } output st5 -utf8_bom_encode :: IORef Bool -> EncodeBuffer +utf8_bom_encode :: IORef Bool -> EncodeBuffer# utf8_bom_encode ref input output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + st0 = do - b <- readIORef ref - if not b then utf8_encode input output + let !(# st1, b #) = unIO (readIORef ref) st0 + if not b then utf8_encode input output st1 else if os - ow < 3 - then return (OutputUnderflow,input,output) + then (# st1,OutputUnderflow,input,output #) else do - writeIORef ref False - writeWord8Buf oraw ow bom0 - writeWord8Buf oraw (ow+1) bom1 - writeWord8Buf oraw (ow+2) bom2 - utf8_encode input output{ bufR = ow+3 } + let !(# st2, () #) = unIO (writeIORef ref False) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw ow bom0) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+1) bom1) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+2) bom2) st4 + utf8_encode input output{ bufR = ow+3 } st5 bom0, bom1, bom2 :: Word8 bom0 = 0xef bom1 = 0xbb bom2 = 0xbf -utf8_decode :: DecodeBuffer +utf8_decode :: DecodeBuffer# utf8_decode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + loop :: Int -> Int -> DecodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - c0 <- readWord8Buf iraw ir + let !(# st1, c0 #) = unIO (readWord8Buf iraw ir) st0 case c0 of _ | c0 <= 0x7f -> do - ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) - loop (ir+1) ow' - | c0 >= 0xc0 && c0 <= 0xc1 -> invalid -- Overlong forms + let !(# st2, ow' #) = unIO (writeCharBuf oraw ow (unsafeChr (fromIntegral c0))) st1 + loop (ir+1) ow' st2 + | c0 >= 0xc0 && c0 <= 0xc1 -> invalid st1 -- Overlong forms | c0 >= 0xc2 && c0 <= 0xdf -> - if iw - ir < 2 then done InputUnderflow ir ow else do - c1 <- readWord8Buf iraw (ir+1) - if (c1 < 0x80 || c1 >= 0xc0) then invalid else do - ow' <- writeCharBuf oraw ow (chr2 c0 c1) - loop (ir+2) ow' + if iw - ir < 2 then done InputUnderflow ir ow st1 else do + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + if (c1 < 0x80 || c1 >= 0xc0) then invalid st2 else do + let !(# st3, ow' #) = unIO (writeCharBuf oraw ow (chr2 c0 c1)) st2 + loop (ir+2) ow' st3 | c0 >= 0xe0 && c0 <= 0xef -> case iw - ir of - 1 -> done InputUnderflow ir ow + 1 -> done InputUnderflow ir ow st1 2 -> do -- check for an error even when we don't have -- the full sequence yet (#3341) - c1 <- readWord8Buf iraw (ir+1) + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 if not (validate3 c0 c1 0x80) - then invalid else done InputUnderflow ir ow + then invalid st2 else done InputUnderflow ir ow st2 _ -> do - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - if not (validate3 c0 c1 c2) then invalid else do - ow' <- writeCharBuf oraw ow (chr3 c0 c1 c2) - loop (ir+3) ow' + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + let !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + if not (validate3 c0 c1 c2) then invalid st3 else do + let !(# st4, ow' #) = unIO (writeCharBuf oraw ow (chr3 c0 c1 c2)) st3 + loop (ir+3) ow' st4 | c0 >= 0xf0 -> case iw - ir of - 1 -> done InputUnderflow ir ow + 1 -> done InputUnderflow ir ow st1 2 -> do -- check for an error even when we don't have -- the full sequence yet (#3341) - c1 <- readWord8Buf iraw (ir+1) + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 if not (validate4 c0 c1 0x80 0x80) - then invalid else done InputUnderflow ir ow + then invalid st2 else done InputUnderflow ir ow st2 3 -> do - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 if not (validate4 c0 c1 c2 0x80) - then invalid else done InputUnderflow ir ow + then invalid st3 else done InputUnderflow ir ow st3 _ -> do - c1 <- readWord8Buf iraw (ir+1) - c2 <- readWord8Buf iraw (ir+2) - c3 <- readWord8Buf iraw (ir+3) - if not (validate4 c0 c1 c2 c3) then invalid else do - ow' <- writeCharBuf oraw ow (chr4 c0 c1 c2 c3) - loop (ir+4) ow' + let !(# st2, c1 #) = unIO (readWord8Buf iraw (ir+1)) st1 + !(# st3, c2 #) = unIO (readWord8Buf iraw (ir+2)) st2 + !(# st4, c3 #) = unIO (readWord8Buf iraw (ir+3)) st3 + if not (validate4 c0 c1 c2 c3) then invalid st4 else do + let !(# st5, ow' #) = unIO (writeCharBuf oraw ow (chr4 c0 c1 c2 c3)) st4 + loop (ir+4) ow' st5 | otherwise -> - invalid + invalid st1 where - invalid = done InvalidSequence ir ow + invalid :: DecodingBuffer# + invalid st' = done InvalidSequence ir ow st' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> DecodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0} else input{ bufL = ir } + !ro = output { bufR = ow } + in (# st', why, ri, ro #) in - loop ir0 ow0 + loop ir0 ow0 st -utf8_encode :: EncodeBuffer +utf8_encode :: EncodeBuffer# utf8_encode input at Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output at Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + st = let - done why !ir !ow = return (why, - if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) - loop !ir !ow - | ow >= os = done OutputUnderflow ir ow - | ir >= iw = done InputUnderflow ir ow + {-# NOINLINE done #-} + done :: CodingProgress -> Int -> Int -> EncodingBuffer# + done why !ir !ow st' = + let !ri = if ir == iw then input{ bufL = 0, bufR = 0 } else input{ bufL = ir } + !ro = output{ bufR = ow } + in (# st', why, ri, ro #) + loop :: Int -> Int -> EncodingBuffer# + loop !ir !ow st0 + | ow >= os = done OutputUnderflow ir ow st0 + | ir >= iw = done InputUnderflow ir ow st0 | otherwise = do - (c,ir') <- readCharBuf iraw ir + let !(# st1, (c,ir') #) = unIO (readCharBuf iraw ir) st0 case ord c of x | x <= 0x7F -> do - writeWord8Buf oraw ow (fromIntegral x) - loop ir' (ow+1) + let !(# st2, () #) = unIO (writeWord8Buf oraw ow (fromIntegral x)) st1 + loop ir' (ow+1) st2 | x <= 0x07FF -> - if os - ow < 2 then done OutputUnderflow ir ow else do + if os - ow < 2 then done OutputUnderflow ir ow st1 else do let (c1,c2) = ord2 c - writeWord8Buf oraw ow c1 - writeWord8Buf oraw (ow+1) c2 - loop ir' (ow+2) - | x <= 0xFFFF -> if isSurrogate c then done InvalidSequence ir ow else do - if os - ow < 3 then done OutputUnderflow ir ow else do + !(# st2, () #) = unIO (writeWord8Buf oraw ow c1) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + loop ir' (ow+2) st3 + | x <= 0xFFFF -> if isSurrogate c then done InvalidSequence ir ow st1 else do + if os - ow < 3 then done OutputUnderflow ir ow st1 else do let (c1,c2,c3) = ord3 c - writeWord8Buf oraw ow c1 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c3 - loop ir' (ow+3) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c1) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c3) st3 + loop ir' (ow+3) st4 | otherwise -> do - if os - ow < 4 then done OutputUnderflow ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow st1 else do let (c1,c2,c3,c4) = ord4 c - writeWord8Buf oraw ow c1 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c3 - writeWord8Buf oraw (ow+3) c4 - loop ir' (ow+4) + !(# st2, () #) = unIO (writeWord8Buf oraw ow c1) st1 + !(# st3, () #) = unIO (writeWord8Buf oraw (ow+1) c2) st2 + !(# st4, () #) = unIO (writeWord8Buf oraw (ow+2) c3) st3 + !(# st5, () #) = unIO (writeWord8Buf oraw (ow+3) c4) st4 + loop ir' (ow+4) st5 in - loop ir0 ow0 + loop ir0 ow0 st -- ----------------------------------------------------------------------------- -- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/536e0538a9256e52229bbf8e10159e35593a155f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/536e0538a9256e52229bbf8e10159e35593a155f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 11:33:51 2023 From: gitlab at gitlab.haskell.org (Bryan R (@chreekat)) Date: Tue, 09 May 2023 07:33:51 -0400 Subject: [Git][ghc/ghc] Deleted branch wip/b/ghcup-metadata-nightly Message-ID: <645a2f9f1f29d_38ffdaa2a08a649726d9@gitlab.mail> Bryan R deleted branch wip/b/ghcup-metadata-nightly at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 11:34:02 2023 From: gitlab at gitlab.haskell.org (Bryan R (@chreekat)) Date: Tue, 09 May 2023 07:34:02 -0400 Subject: [Git][ghc/ghc][master] Fix up rules for ghcup-metadata-nightly-push Message-ID: <645a2faabf9e8_38ffdaa273eb1c974839@gitlab.mail> Bryan R pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0e2df4c9 by Bryan Richter at 2023-05-09T12:03:35+03:00 Fix up rules for ghcup-metadata-nightly-push - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1048,7 +1048,7 @@ ghcup-metadata-nightly: rules: - if: $NIGHTLY -# Update the +# Update the ghcup metadata with information about this nightly pipeline ghcup-metadata-nightly-push: stage: deploy image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" @@ -1072,11 +1072,8 @@ ghcup-metadata-nightly-push: - git commit -m "Update metadata" - git push gitlab_origin HEAD:updates -o ci.skip rules: - - if: $NIGHTLY # Only run the update on scheduled nightly pipelines, ie once a day - - if: $CI_PIPELINE_SOURCE == "schedule" - # And only update the metadata for master branch - - if: '$CI_COMMIT_BRANCH == "master"' + - if: $NIGHTLY && $CI_PIPELINE_SOURCE == "schedule" && $CI_COMMIT_BRANCH == "master" ghcup-metadata-release: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e2df4c9ac59a10080bd6e029e83a355ecd01c8b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e2df4c9ac59a10080bd6e029e83a355ecd01c8b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 12:33:37 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 08:33:37 -0400 Subject: [Git][ghc/ghc][wip/exception-context] hi Message-ID: <645a3da1841a0_38ffdaa6bfbdb8100149@gitlab.mail> Ben Gamari pushed to branch wip/exception-context at Glasgow Haskell Compiler / GHC Commits: 68027225 by Ben Gamari at 2023-05-09T08:33:30-04:00 hi - - - - - 1 changed file: - libraries/base/GHC/IO.hs Changes: ===================================== libraries/base/GHC/IO.hs ===================================== @@ -188,7 +188,12 @@ catch :: Exception e -> (e -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a -- See #exceptions_and_strictness#. -catch io handler = catchNoCause io (\e -> withCausedBy e (handler e)) +catch (IO io) handler = IO $ catch# io handler' + where + handler' e = + case fromException e of + Just e' -> unIO (withCausedBy e $ handler e') + Nothing -> raiseIO# e -- | Catch an exception without adding a 'CausedBy' 'ExceptionContext' to any -- exceptions thrown by the handler. See the documentation of 'catch' for a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68027225a6a31e3dbaadee50139e15974c81ac7e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68027225a6a31e3dbaadee50139e15974c81ac7e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 12:34:51 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 08:34:51 -0400 Subject: [Git][ghc/ghc][wip/T13660] base: Ensure that FilePaths don't contain NULs Message-ID: <645a3deb7aa45_38ffdaa49c33401002131@gitlab.mail> Ben Gamari pushed to branch wip/T13660 at Glasgow Haskell Compiler / GHC Commits: 8c28341e by Ben Gamari at 2023-05-09T08:34:44-04:00 base: Ensure that FilePaths don't contain NULs POSIX filepaths may not contain the NUL octet but previously we did not reject such paths. This could be exploited by untrusted input to cause discrepancies between various `FilePath` queries and the opened filename. For instance, `readFile "hello.so\x00.txt"` would open the file `"hello.so"` yet `takeFileExtension` would return `".txt"`. The same argument applies to Windows FilePaths Fixes #13660. - - - - - 1 changed file: - libraries/base/System/Posix/Internals.hs Changes: ===================================== libraries/base/System/Posix/Internals.hs ===================================== @@ -34,7 +34,7 @@ import System.Posix.Types import Foreign import Foreign.C --- import Data.Bits +import Data.OldList (elem) import Data.Maybe #if !defined(HTYPE_TCFLAG_T) @@ -43,6 +43,7 @@ import System.IO.Error import GHC.Base import GHC.Num +import GHC.Ptr import GHC.Real import GHC.IO import GHC.IO.IOMode @@ -164,13 +165,23 @@ fdGetMode fd = do #if defined(mingw32_HOST_OS) withFilePath :: FilePath -> (CWString -> IO a) -> IO a -withFilePath = withCWString +withFilePath fp f = do + checkForInteriorNuls fp + withCWString fp f newFilePath :: FilePath -> IO CWString -newFilePath = newCWString +newFilePath fp = do + checkForInteriorNuls fp + newCWString fp peekFilePath :: CWString -> IO FilePath peekFilePath = peekCWString + +-- | Check a 'FilePath' for internal NUL codepoints as these are +-- disallowed in Windows filepaths. See #13660. +checkForInteriorNuls :: FilePath -> IO () +checkForInteriorNuls fp = when ('\0' `elem` fp) (throwInternalNulError fp) + #else withFilePath :: FilePath -> (CString -> IO a) -> IO a @@ -178,13 +189,43 @@ newFilePath :: FilePath -> IO CString peekFilePath :: CString -> IO FilePath peekFilePathLen :: CStringLen -> IO FilePath -withFilePath fp f = getFileSystemEncoding >>= \enc -> GHC.withCString enc fp f -newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp +withFilePath fp f = do + enc <- getFileSystemEncoding + GHC.withCStringLen0 enc fp $ \(str, len) -> do + checkForInteriorNuls fp (str, len) + f str +newFilePath fp = do + enc <- getFileSystemEncoding + (str, len) <- GHC.newCStringLen0 enc fp + checkForInteriorNuls fp (str, len) + return str peekFilePath fp = getFileSystemEncoding >>= \enc -> GHC.peekCString enc fp peekFilePathLen fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp +-- | Check an encoded 'FilePath' for internal NUL octets as these are +-- disallowed in POSIX filepaths. See #13660. +checkForInteriorNuls :: FilePath -> CStringLen -> IO () +checkForInteriorNuls fp (str, len) = + when (len' /= len) (throwInternalNulError fp) + -- N.B. If the string contains internal NUL codeunits then the strlen will + -- indicate a size smaller than that returned by withCStringLen. + where + len' = case str of Ptr ptr -> I# (cstringLength# ptr) #endif +throwInternalNulError :: FilePath -> IO a +throwInternalNulError fp = ioError err + where + err = + IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "checkForInteriorNuls" + , ioe_description = "FilePaths must not contain internal NUL code units." + , ioe_errno = Nothing + , ioe_filename = Just fp + } + -- --------------------------------------------------------------------------- -- Terminal-related stuff View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c28341e66558cf0c1b382c32c7f5ddcd7ab45ae -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c28341e66558cf0c1b382c32c7f5ddcd7ab45ae You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 12:42:03 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 08:42:03 -0400 Subject: [Git][ghc/ghc][wip/ioref-swap-xchg] 164 commits: Handle records in the renamer Message-ID: <645a3f9b1fd40_38ffdaa49c33401005442@gitlab.mail> Ben Gamari pushed to branch wip/ioref-swap-xchg at Glasgow Haskell Compiler / GHC Commits: 3f374399 by sheaf at 2023-03-29T13:57:33+02:00 Handle records in the renamer This patch moves the field-based logic for disambiguating record updates to the renamer. The type-directed logic, scheduled for removal, remains in the typechecker. To do this properly (and fix the myriad of bugs surrounding the treatment of duplicate record fields), we took the following main steps: 1. Create GREInfo, a renamer-level equivalent to TyThing which stores information pertinent to the renamer. This allows us to uniformly treat imported and local Names in the renamer, as described in Note [GREInfo]. 2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which distinguished between normal names and field names, we now store simple Names in GlobalRdrElt, along with the new GREInfo information which allows us to recover the FieldLabel for record fields. 3. Add namespacing for record fields, within the OccNames themselves. This allows us to remove the mangling of duplicate field selectors. This change ensures we don't print mangled names to the user in error messages, and allows us to handle duplicate record fields in Template Haskell. 4. Move record disambiguation to the renamer, and operate on the level of data constructors instead, to handle #21443. The error message text for ambiguous record updates has also been changed to reflect that type-directed disambiguation is on the way out. (3) means that OccEnv is now a bit more complex: we first key on the textual name, which gives an inner map keyed on NameSpace: OccEnv a ~ FastStringEnv (UniqFM NameSpace a) Note that this change, along with (2), both increase the memory residency of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to regress somewhat in compile-time allocation. Even though (3) simplified a lot of code (in particular the treatment of field selectors within Template Haskell and in error messages), it came with one important wrinkle: in the situation of -- M.hs-boot module M where { data A; foo :: A -> Int } -- M.hs module M where { data A = MkA { foo :: Int } } we have that M.hs-boot exports a variable foo, which is supposed to match with the record field foo that M exports. To solve this issue, we add a new impedance-matching binding to M foo{var} = foo{fld} This mimics the logic that existed already for impedance-binding DFunIds, but getting it right was a bit tricky. See Note [Record field impedance matching] in GHC.Tc.Module. We also needed to be careful to avoid introducing space leaks in GHCi. So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in ModIface. This means stubbing out all the GREInfo fields, with the function forceGlobalRdrEnv. When we read it back in, we rehydrate with rehydrateGlobalRdrEnv. This robustly avoids any space leaks caused by retaining old type environments. Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063 Updates haddock submodule ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiLayerModulesDefsGhci MultiLayerModulesNoCode T13701 T14697 hard_hole_fits ------------------------- - - - - - 4f1940f0 by sheaf at 2023-03-29T13:57:33+02:00 Avoid repeatedly shadowing in shadowNames This commit refactors GHC.Type.Name.Reader.shadowNames to first accumulate all the shadowing arising from the introduction of a new set of GREs, and then applies all the shadowing to the old GlobalRdrEnv in one go. - - - - - d246049c by sheaf at 2023-03-29T13:57:34+02:00 igre_prompt_env: discard "only-qualified" names We were unnecessarily carrying around names only available qualified in igre_prompt_env, violating the icReaderEnv invariant. We now get rid of these, as they aren't needed for the shadowing computation that igre_prompt_env exists for. Fixes #23177 ------------------------- Metric Decrease: T14052 T14052Type ------------------------- - - - - - 41a572f6 by Matthew Pickering at 2023-03-29T16:17:21-04:00 hadrian: Fix path to HpcParser.y The source for this project has been moved into a src/ folder so we also need to update this path. Fixes #23187 - - - - - b159e0e9 by doyougnu at 2023-03-30T01:40:08-04:00 js: split JMacro into JS eDSL and JS syntax This commit: Splits JExpr and JStat into two nearly identical DSLs: - GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a value cannot be unsaturated, or, a value of this DSL is a witness that a value of GHC.JS.Unsat has been saturated - GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation. Then all binary and outputable instances are changed to use GHC.JS.Syntax. This moves us closer to closing out #22736 and #22352. See #22736 for roadmap. ------------------------- Metric Increase: CoOpt_Read LargeRecord ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T10858 T11195 T11374 T11822 T12227 T12707 T13035 T13253 T13253-spj T13379 T14683 T15164 T15703 T16577 T17096 T17516 T17836 T18140 T18282 T18304 T18478 T18698a T18698b T18923 T1969 T19695 T20049 T21839c T3064 T4801 T5321FD T5321Fun T5631 T5642 T783 T9198 T9233 T9630 TcPlugin_RewritePerf WWRec ------------------------- - - - - - f4f1f14f by Sylvain Henry at 2023-03-30T01:40:49-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. Also used the opportunity to reenable 64-bit Word/Int tests - - - - - a5360490 by Ben Gamari at 2023-03-30T01:41:25-04:00 testsuite: Fix racing prints in T21465 As noted in #23155, we previously failed to add flushes necessary to ensure predictable output. Fixes #23155. - - - - - 98b5cf67 by Matthew Pickering at 2023-03-30T09:58:40+01:00 Revert "ghc-heap: remove wrong Addr# coercion (#23181)" This reverts commit f4f1f14f8009c3c120b8b963ec130cbbc774ec02. This fails to build with GHC-9.2 as a boot compiler. See #23195 for tracking this issue. - - - - - 61a2dfaa by Bodigrim at 2023-03-30T14:35:57-04:00 Add {-# WARNING #-} to Data.List.{head,tail} - - - - - 8f15c47c by Bodigrim at 2023-03-30T14:35:57-04:00 Fixes to accomodate Data.List.{head,tail} with {-# WARNING #-} - - - - - 7c7dbade by Bodigrim at 2023-03-30T14:35:57-04:00 Bump submodules - - - - - d2d8251b by Bodigrim at 2023-03-30T14:35:57-04:00 Fix tests - - - - - 3d38dcb6 by sheaf at 2023-03-30T14:35:57-04:00 Proxies for head and tail: review suggestions - - - - - 930edcfd by sheaf at 2023-03-30T14:36:33-04:00 docs: move RecordUpd changelog entry to 9.8 This was accidentally included in the 9.6 changelog instead of the 9.6 changelog. - - - - - 6f885e65 by sheaf at 2023-03-30T14:37:09-04:00 Add LANGUAGE GADTs to GHC.Rename.Env We need to enable this extension for the file to compile with ghc 9.2, as we are pattern matching on a GADT and this required the GADT extension to be enabled until 9.4. - - - - - 6d6a37a8 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: make lint-ci-config job fast again We don't pin our nixpkgs revision and tracks the default nixpkgs-unstable channel anyway. Instead of using haskell.packages.ghc924, we should be using haskell.packages.ghc92 to maximize the binary cache hit rate and make lint-ci-config job fast again. Also bumps the nix docker image to the latest revision. - - - - - ef1548c4 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: ensure that all non-i386 pipelines do parallel xz compression We can safely enable parallel xz compression for non-i386 pipelines. However, previously we didn't export XZ_OPT, so the xz process won't see it if XZ_OPT hasn't already been set in the current job. - - - - - 20432d16 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: unset CROSS_EMULATOR for js job - - - - - 4a24dbbe by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: fix lint-testsuite job The list_broken make target will transitively depend on the calibrate.out target, which used STAGE1_GHC instead of TEST_HC. It really should be TEST_HC since that's what get passed in the gitlab CI config. - - - - - cea56ccc by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: use alpine3_17-wasm image for wasm jobs Bump the ci-images dependency and use the new alpine3_17-wasm docker image for wasm jobs. - - - - - 79d0cb32 by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - e7392b4e by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Normalize away differences in ghc executable name - - - - - ee160d06 by Ben Gamari at 2023-03-30T18:43:53+00:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - 30c84511 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: don't add optllvm way for wasm32 - - - - - f1beee36 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: normalize the .wasm extension - - - - - a984a103 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: strip the cross ghc prefix in output and error message - - - - - f7478d95 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: handle target executable extension - - - - - 8fe8b653 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: mypy typing error fixes This patch fixes some mypy typing errors which weren't caught in previous linting jobs. - - - - - 0149f32f by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: use context variable instead of thread-local variable This patch changes a thread-local variable to context variable instead, which works as intended when the testsuite transitions to use asyncio & coroutines instead of multi-threading to concurrently run test cases. Note that this also raises the minimum Python version to 3.7. - - - - - ea853ff0 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: asyncify the testsuite driver This patch refactors the testsuite driver, gets rid of multi-threading logic for running test cases concurrently, and uses asyncio & coroutines instead. This is not yak shaving for its own sake; the previous multi-threading logic is prone to livelock/deadlock conditions for some reason, even if the total number of threads is bounded to a thread pool's capacity. The asyncify change is an internal implementation detail of the testsuite driver and does not impact most GHC maintainers out there. The patch does not touch the .T files, test cases can be added/modified the exact same way as before. - - - - - 0077cb22 by Matthew Pickering at 2023-03-31T21:28:28-04:00 Add test for T23184 There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj at microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 A bunch of changes related to eta reduction This is a large collection of changes all relating to eta reduction, originally triggered by #18993, but there followed a long saga. Specifics: ...lots of lines omitted... Other incidental changes * Fix a fairly long-standing outright bug in the ApplyToVal case of GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the tail of 'dmds' in the recursive call, which meant the demands were All Wrong. I have no idea why this has not caused problems before now. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes. - - - - - 62d25071 by mangoiv at 2023-04-01T04:20:01-04:00 [feat] make ($) representation polymorphic - this change was approved by the CLC in [1] following a CLC proposal [2] - make ($) representation polymorphic (adjust the type signature) - change ($) implementation to allow additional polymorphism - adjust the haddock of ($) to reflect these changes - add additional documentation to document these changes - add changelog entry - adjust tests (move now succeeding tests and adjust stdout of some tests) [1] https://github.com/haskell/core-libraries-committee/issues/132#issuecomment-1487456854 [2] https://github.com/haskell/core-libraries-committee/issues/132 - - - - - 77c33fb9 by Artem Pelenitsyn at 2023-04-01T04:20:41-04:00 User Guide: update copyright year: 2020->2023 - - - - - 3b5be05a by doyougnu at 2023-04-01T09:42:31-04:00 driver: Unit State Data.Map -> GHC.Unique.UniqMap In pursuit of #22426. The driver and unit state are major contributors. This commit also bumps the haddock submodule to reflect the API changes in UniqMap. ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp T10421 T10547 T12150 T12234 T12425 T13035 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T5837 T6048 T9198 ------------------------- - - - - - a84fba6e by Torsten Schmits at 2023-04-01T09:43:12-04:00 Add structured error messages for GHC.Tc.TyCl Tracking ticket: #20117 MR: !10183 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 6e2eb275 by doyougnu at 2023-04-01T18:27:56-04:00 JS: Linker: use saturated JExpr Follow on to MR!10142 in pursuit of #22736 - - - - - 3da69346 by sheaf at 2023-04-01T18:28:37-04:00 Improve haddocks of template-haskell Con datatype This adds a bit more information, in particular about the lists of constructors in the GadtC and RecGadtC cases. - - - - - 3b7bbb39 by sheaf at 2023-04-01T18:28:37-04:00 TH: revert changes to GadtC & RecGadtC Commit 3f374399 included a breaking-change to the template-haskell library when it made the GadtC and RecGadtC constructors take non-empty lists of names. As this has the potential to break many users' packages, we decided to revert these changes for now. - - - - - f60f6110 by Bodigrim at 2023-04-02T18:59:30-04:00 Rework documentation for data Char - - - - - 43ebd5dc by Bodigrim at 2023-04-02T19:00:09-04:00 cmm: implement parsing of MO_AtomicRMW from hand-written CMM files Fixes #23206 - - - - - ab9cd52d by Sylvain Henry at 2023-04-03T08:15:21-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. - - - - - 2b2afff3 by Matthew Pickering at 2023-04-03T08:15:58-04:00 hadrian: Update bootstrap plans for 9.2.6, 9.2.7, 9.4.4, 9.4.5, 9.6.1 Also fixes the ./generate_bootstrap_plans script which was recently broken We can hopefully drop the 9.2 plans soon but they still work so kept them around for now. - - - - - c2605e25 by Matthew Pickering at 2023-04-03T08:15:58-04:00 ci: Add job to test 9.6 bootstrapping - - - - - 53e4d513 by Krzysztof Gogolewski at 2023-04-03T08:16:35-04:00 hadrian: Improve option parsing Several options in Hadrian had their argument marked as optional (`OptArg`), but if the argument wasn't there they were just giving an error. It's more idiomatic to mark the argument as required instead; the code uses less Maybes, the parser can enforce that the argument is present, --help gives better output. - - - - - a8e36892 by Sylvain Henry at 2023-04-03T08:17:16-04:00 JS: fix issues with FD api support - Add missing implementations for fcntl_read/write/lock - Fix fdGetMode These were found while implementing TH in !9779. These functions must be used somehow by the external interpreter code. - - - - - 8b092910 by Haskell-mouse at 2023-04-03T19:31:26-04:00 Convert diagnostics in GHC.Rename.HsType to proper TcRnMessage I've turned all occurrences of TcRnUnknownMessage in GHC.Rename.HsType module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnDataKindsError TcRnUnusedQuantifiedTypeVar TcRnIllegalKindSignature TcRnUnexpectedPatSigType TcRnSectionPrecedenceError TcRnPrecedenceParsingError TcRnIllegalKind TcRnNegativeNumTypeLiteral TcRnUnexpectedKindVar TcRnBindMultipleVariables TcRnBindVarAlreadyInScope - - - - - 220a7a48 by Krzysztof Gogolewski at 2023-04-03T19:32:02-04:00 Fixes around unsafeCoerce# 1. `unsafeCoerce#` was documented in `GHC.Prim`. But since the overhaul in 74ad75e87317, `unsafeCoerce#` is no longer defined there. I've combined the documentation in `GHC.Prim` with the `Unsafe.Coerce` module. 2. The documentation of `unsafeCoerce#` stated that you should not cast a function to an algebraic type, even if you later cast it back before applying it. But ghci was doing that type of cast, as can be seen with 'ghci -ddump-ds' and typing 'x = not'. I've changed it to use Any following the documentation. - - - - - 9095e297 by Matthew Craven at 2023-04-04T01:04:10-04:00 Add a few more memcpy-ish primops * copyMutableByteArrayNonOverlapping# * copyAddrToAddr# * copyAddrToAddrNonOverlapping# * setAddrRange# The implementations of copyBytes, moveBytes, and fillBytes in base:Foreign.Marshal.Utils now use these new primops, which can cause us to work a bit harder generating code for them, resulting in the metric increase in T21839c observed by CI on some architectures. But in exchange, we get better code! Metric Increase: T21839c - - - - - f7da530c by Matthew Craven at 2023-04-04T01:04:10-04:00 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. - - - - - cd00e321 by sheaf at 2023-04-04T01:04:50-04:00 Relax assertion in varToRecFieldOcc When using Template Haskell, it is possible to re-parent a field OccName belonging to one data constructor to another data constructor. The lsp-types package did this in order to "extend" a data constructor with additional fields. This ran into an assertion in 'varToRecFieldOcc'. This assertion can simply be relaxed, as the resulting splices are perfectly sound. Fixes #23220 - - - - - eed0d930 by Sylvain Henry at 2023-04-04T11:09:15-04:00 GHCi.RemoteTypes: fix doc and avoid unsafeCoerce (#23201) - - - - - 071139c3 by Ryan Scott at 2023-04-04T11:09:51-04:00 Make INLINE pragmas for pattern synonyms work with TH Previously, the code for converting `INLINE <name>` pragmas from TH splices used `vNameN`, which assumed that `<name>` must live in the variable namespace. Pattern synonyms, on the other hand, live in the constructor namespace. I've fixed the issue by switching to `vcNameN` instead, which works for both the variable and constructor namespaces. Fixes #23203. - - - - - 7c16f3be by Krzysztof Gogolewski at 2023-04-04T17:13:00-04:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). - - - - - c165f079 by sheaf at 2023-04-04T17:13:40-04:00 Add testcase for #23192 This issue around solving of constraints arising from superclass expansion using other constraints also borned from superclass expansion was the topic of commit aed1974e. That commit made sure we don't emit a "redundant constraint" warning in a situation in which removing the constraint would cause errors. Fixes #23192 - - - - - d1bb16ed by Ben Gamari at 2023-04-06T03:40:45-04:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 - - - - - 04b80850 by Brandon Chinn at 2023-04-06T03:41:21-04:00 Fix reverse flag for -Wunsupported-llvm-version - - - - - 0c990e13 by Pierre Le Marre at 2023-04-06T10:16:29+00:00 Add release note for GHC.Unicode refactor in base-4.18. Also merge CLC proposal 130 in base-4.19 with CLC proposal 59 in base-4.18 and add proper release date. - - - - - cbbfb283 by Alex Dixon at 2023-04-07T18:27:45-04:00 Improve documentation for ($) (#22963) - - - - - 5193c2b0 by Alex Dixon at 2023-04-07T18:27:45-04:00 Remove trailing whitespace from ($) commentary - - - - - b384523b by Sebastian Graf at 2023-04-07T18:27:45-04:00 Adjust wording wrt representation polymorphism of ($) - - - - - 6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00 Add structured error messages for GHC.Tc.TyCl.Utils Tracking ticket: #20117 MR: !10251 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00 Renamer: don't call addUsedGRE on an exact Name When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc, we could end up calling addUsedGRE on an exact Name, which would then lead to a panic in the bestImport function: it would be incapable of processing a GRE which is not local but also not brought into scope by any imports (as it is referred to by its unique instead). Fixes #23240 - - - - - bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00 Set base 'maintainer' field to CLC - - - - - ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00 Clarify a couple of Notes about 'nospec' - - - - - ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 3e3a6be4 by Ben Gamari at 2023-05-08T12:15:19+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 78c8dc50 by Torsten Schmits at 2023-05-08T21:41:51-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 0e2df4c9 by Bryan Richter at 2023-05-09T12:03:35+03:00 Fix up rules for ghcup-metadata-nightly-push - - - - - b970e64f by Ben Gamari at 2023-05-09T08:41:33-04:00 testsuite: Add test for atomicSwapIORef - - - - - 81cfefd2 by Ben Gamari at 2023-05-09T08:41:53-04:00 compiler: Implement atomicSwapIORef with xchg As requested by @treeowl in CLC#139. - - - - - 6b29154d by Ben Gamari at 2023-05-09T08:41:53-04:00 Make atomicSwapMutVar# an inline primop - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/generate_job_metadata - .gitlab/generate_jobs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - .gitmodules - cabal.project-reinstall - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/Wasm/Types.hs - compiler/GHC/CmmToAsm/Wasm/Utils.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core/ConLike.hs - compiler/GHC/Core/DataCon.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ec9c1e8ba3e0f3d94b4caca5d72d7aca13f7aee4...6b29154de6b63597553c5b69b9974c8838a7a80a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ec9c1e8ba3e0f3d94b4caca5d72d7aca13f7aee4...6b29154de6b63597553c5b69b9974c8838a7a80a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 13:55:05 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Tue, 09 May 2023 09:55:05 -0400 Subject: [Git][ghc/ghc][wip/romes/target-has-rts-linker] Move "target has RTS linker" out of settings Message-ID: <645a50b99ea93_38ffdaaddca0c0106322a@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/target-has-rts-linker at Glasgow Haskell Compiler / GHC Commits: aef4155c by Rodrigo Mesquita at 2023-05-09T14:54:50+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Note that previously we would consider `powerpc`s and `s390x`s other than `powerpc-ibm-aix*` and `s390x-ibm-linux` to have an RTS linker, but the RTS linker supports neither platform. Closes #23361 - - - - - 10 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/Platform.hs - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -4727,8 +4727,9 @@ compilerInfo dflags ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), - ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), + ("Have native code generator", showBool $ platformNcgSupported platform), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make at . ===================================== compiler/GHC/Platform.hs ===================================== @@ -29,6 +29,7 @@ module GHC.Platform , platformInIntRange , platformInWordRange , platformCConvNeedsExtension + , platformHasRTSLinker , PlatformMisc(..) , SseVersion (..) , BmiVersion (..) @@ -271,6 +272,20 @@ platformCConvNeedsExtension platform = case platformArch platform of | OSDarwin <- platformOS platform -> True _ -> False +-- | Does this platform have an RTS linker? +platformHasRTSLinker :: Platform -> Bool +platformHasRTSLinker p = case archOS_arch (platformArchOS p) of + ArchPPC -> False -- powerpc + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False + ArchRISCV64 -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + ArchWasm32 -> False + _ -> True + + -------------------------------------------------- -- Instruction sets ===================================== configure.ac ===================================== @@ -330,18 +330,6 @@ if test x"$TablesNextToCode" = xYES; then fi AC_SUBST(TablesNextToCode) -dnl ** Does target have runtime linker support? -dnl -------------------------------------------------------------- -case "$target" in - powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) - TargetHasRTSLinker=NO - ;; - *) - TargetHasRTSLinker=YES - ;; -esac -AC_SUBST(TargetHasRTSLinker) - # Requires FPTOOLS_SET_PLATFORMS_VARS to be run first. FP_FIND_ROOT ===================================== distrib/configure.ac.in ===================================== @@ -20,9 +20,6 @@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ -TargetHasRTSLinker=@TargetHasRTSLinker@ -AC_SUBST(TargetHasRTSLinker) - TargetHasLibm=@TargetHasLibm@ AC_SUBST(TargetHasLibm) ===================================== hadrian/bindist/Makefile ===================================== @@ -116,7 +116,6 @@ lib/settings : config.mk @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ - @echo ',("target has RTS linker", "$(TargetHasRTSLinker)")' >> $@ @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ @echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -253,7 +253,6 @@ TargetWordBigEndian = @TargetWordBigEndian@ TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ TargetHasIdentDirective = @TargetHasIdentDirective@ TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -173,7 +173,6 @@ target-word-big-endian = @TargetWordBigEndian@ target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@ target-has-ident-directive = @TargetHasIdentDirective@ target-has-subsections-via-symbols = @TargetHasSubsectionsViaSymbols@ -target-has-rts-linker = @TargetHasRTSLinker@ target-has-libm = @TargetHasLibm@ target-arm-version = @ARM_ISA@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -79,7 +79,6 @@ data Setting = BuildArch | TargetOsHaskell | TargetArmVersion | TargetWordSize - | TargetHasRtsLinker | BourneShell -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). @@ -181,7 +180,6 @@ setting key = lookupSystemConfig $ case key of TargetArchHaskell -> "target-arch-haskell" TargetOsHaskell -> "target-os-haskell" TargetWordSize -> "target-word-size" - TargetHasRtsLinker -> "target-has-rts-linker" BourneShell -> "bourne-shell" bootIsStage0 :: Stage -> Stage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -451,7 +451,6 @@ generateSettings = do , ("target has GNU nonexec stack", expr $ lookupSystemConfig "target-has-gnu-nonexec-stack") , ("target has .ident directive", expr $ lookupSystemConfig "target-has-ident-directive") , ("target has subsections via symbols", expr $ lookupSystemConfig "target-has-subsections-via-symbols") - , ("target has RTS linker", expr $ lookupSystemConfig "target-has-rts-linker") , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) , ("LLVM target", getSetting LlvmTarget) ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -126,7 +126,10 @@ inTreeCompilerArgs stg = do libdir <- System.FilePath.normalise . (top -/-) <$> stageLibPath stg - rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker + -- For this information, we need to query ghc --info, however, that would + -- require building ghc, which we don't want to do here. Therefore, the + -- logic from `platformHasRTSLinker` is duplicated here. + let rtsLinker = arch `elem` ["powerpc", "powerpc64", "powerpc64le", "s390x", "riscv64", "loongarch64", "javascript", "wasm32"] return TestCompilerArgs{..} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aef4155c1e4c6ce75c523b43b4dfb748faeb5ac4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aef4155c1e4c6ce75c523b43b4dfb748faeb5ac4 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 14:19:01 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 09 May 2023 10:19:01 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Add structured error messages for GHC.IfaceToCore Message-ID: <645a565573e59_38ffdaaf4971181075746@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 78c8dc50 by Torsten Schmits at 2023-05-08T21:41:51-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 0e2df4c9 by Bryan Richter at 2023-05-09T12:03:35+03:00 Fix up rules for ghcup-metadata-nightly-push - - - - - 1d98a68e by doyougnu at 2023-05-09T10:18:38-04:00 JS: add GHC.JS.Optimizer, remove RTS.Printer, add Linker.Opt This MR changes some simple optimizations and is a first step in re-architecting the JS backend pipeline to add the optimizer. In particular it: - removes simple peep hole optimizations from `GHC.StgToJS.Printer` and removes that module - adds module `GHC.JS.Optimizer` - defines the same peep hole opts that were removed only now they are `Syntax -> Syntax` transformations rather than `Syntax -> JS code` optimizations - hooks the optimizer into code gen - adds FuncStat and ForStat constructors to the backend. Working Ticket: - #22736 Related MRs: - MR !10142 - MR !10000 ------------------------- Metric Decrease: CoOpt_Read ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T12707 T13253 T13253-spj T15164 T17516 T18140 T18282 T18698a T18698b T18923 T1969 T19695 T20049 T3064 T5321FD T5321Fun T783 T9198 T9233 T9630 ------------------------- - - - - - f7c1e9eb by Krzysztof Gogolewski at 2023-05-09T10:18:39-04:00 Add a regression test for #21050 - - - - - 26 changed files: - .gitlab-ci.yml - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/JS/Make.hs - + compiler/GHC/JS/Optimizer.hs - compiler/GHC/JS/Ppr.hs - compiler/GHC/JS/Syntax.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/JS/Unsat/Syntax.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Printer.hs → compiler/GHC/StgToJS/Linker/Opt.hs - compiler/GHC/StgToJS/Object.hs - compiler/GHC/StgToJS/Rts/Rts.hs - compiler/GHC/Types/Error/Codes.hs - compiler/ghc.cabal.in - + testsuite/tests/javascript/opt/all.T - + testsuite/tests/javascript/opt/deadCodeElim.hs - + testsuite/tests/javascript/opt/deadCodeElim.stdout - testsuite/tests/linters/notes.stdout - + testsuite/tests/th/T21050.hs - + testsuite/tests/th/T21050.stderr - testsuite/tests/th/all.T Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1048,7 +1048,7 @@ ghcup-metadata-nightly: rules: - if: $NIGHTLY -# Update the +# Update the ghcup metadata with information about this nightly pipeline ghcup-metadata-nightly-push: stage: deploy image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" @@ -1072,11 +1072,8 @@ ghcup-metadata-nightly-push: - git commit -m "Update metadata" - git push gitlab_origin HEAD:updates -o ci.skip rules: - - if: $NIGHTLY # Only run the update on scheduled nightly pipelines, ie once a day - - if: $CI_PIPELINE_SOURCE == "schedule" - # And only update the metadata for master branch - - if: '$CI_COMMIT_BRANCH == "master"' + - if: $NIGHTLY && $CI_PIPELINE_SOURCE == "schedule" && $CI_COMMIT_BRANCH == "master" ghcup-metadata-release: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -65,6 +65,8 @@ interfaceErrorHints = \ case missingInterfaceErrorHints err Can'tFindNameInInterface {} -> noHints + CircularImport {} -> + noHints missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] missingInterfaceErrorHints = \case @@ -86,6 +88,8 @@ interfaceErrorReason (Can'tFindInterface err _) = missingInterfaceErrorReason err interfaceErrorReason (Can'tFindNameInInterface {}) = ErrorWithoutFlag +interfaceErrorReason (CircularImport {}) + = ErrorWithoutFlag missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason missingInterfaceErrorReason = \ case @@ -287,6 +291,9 @@ interfaceErrorDiagnostic opts = \ case LookingForSig sig -> hang (text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon) 2 (missingInterfaceErrorDiagnostic opts err) + CircularImport mod -> + text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc readInterfaceErrorDiagnostic = \ case ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -45,6 +45,7 @@ data IfaceMessage | Can'tFindNameInInterface Name [TyThing] -- possibly relevant TyThings + | CircularImport !Module deriving Generic data MissingInterfaceError ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -605,7 +605,7 @@ tcHiBootIface hsc_src mod (LookingForHiBoot mod) in failWithTc (TcRnInterfaceError diag) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) + NotBoot -> failWithTc (TcRnInterfaceError (CircularImport mod)) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} @@ -613,11 +613,6 @@ tcHiBootIface hsc_src mod need = text "Need the hi-boot interface for" <+> ppr mod <+> text "to compare against the Real Thing" - moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) - <+> text "depends on itself" - - - mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo mkSelfBootInfo iface mds = do -- NB: This is computed DIRECTLY from the ModIface rather ===================================== compiler/GHC/JS/Make.hs ===================================== @@ -83,7 +83,7 @@ module GHC.JS.Make -- $intro_funcs , var , jString - , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally + , jLam, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally -- * Combinators -- $combinators , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) @@ -253,7 +253,7 @@ jLam f = ValExpr . UnsatVal . IS $ do -- of the enclosed expression. The result is a block statement. -- Usage: -- --- @jVar $ \x y -> mconcat [jVar x ||= one_, jVar y ||= two_, jVar x + jVar y]@ +-- @jVar $ \x y -> mconcat [x ||= one_, y ||= two_, x + y]@ jVar :: ToSat a => a -> JStat jVar f = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] @@ -262,6 +262,9 @@ jVar f = UnsatBlock . IS $ do addDecls x = x return $ addDecls block +jFunction :: Ident -> [Ident] -> JStat -> JStat +jFunction name args body = FuncStat name args body + -- | Create a 'for in' statement. -- Usage: -- @@ -279,6 +282,23 @@ jForEachIn e f = UnsatBlock . IS $ do let i = head is return $ decl i `mappend` ForInStat True i e block +-- | Create a 'for' statement given a function for initialization, a predicate +-- to step to, a step and a body +-- Usage: +-- +-- @ jFor (|= zero_) (.<. Int 65536) preIncrS +-- (\j -> ...something with the counter j...)@ +-- +jFor :: (JExpr -> JStat) + -> (JExpr -> JExpr) + -> (JExpr -> JStat) + -> (JExpr -> JStat) + -> JStat +jFor init pred step body = jVar $ \i -> ForStat (init i) (pred i) (step i) (body i) + +jForNoDecl :: Ident -> JExpr -> JExpr -> JStat -> JStat -> JStat +jForNoDecl i initial p step body = ForStat (toJExpr i |= initial) p step body + -- | As with "jForIn" but creating a \"for each in\" statement. jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat jTryCatchFinally s f s2 = UnsatBlock . IS $ do @@ -294,13 +314,6 @@ var = ValExpr . JVar . TxtI jString :: FastString -> JExpr jString = toJExpr --- | Create a 'for' statement -jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat -jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b'] - where b' = case toStat b of - BlockStat xs -> BlockStat $ xs ++ [after] - x -> BlockStat [x,after] - -- | construct a js declaration with the given identifier decl :: Ident -> JStat decl i = DeclStat i Nothing ===================================== compiler/GHC/JS/Optimizer.hs ===================================== @@ -0,0 +1,271 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Optimizer +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Optimizer is a shallow embedding of a peephole optimizer. That is, +-- this module defines transformations over the JavaScript IR in +-- 'GHC.JS.Syntax', transforming the IR forms from inefficient, or +-- non-idiomatic, JavaScript to more efficient and idiomatic JavaScript. The +-- optimizer is written in continuation passing style so optimizations +-- compose. +-- +-- * Architecture of the optimizer +-- +-- The design is that each optimization pattern matches on the head of a +-- block by pattern matching onto the head of the stream of nodes in the +-- JavaScript IR. If an optimization gets a successful match then it performs +-- whatever rewrite is necessary and then calls the 'loop' continuation. This +-- ensures that the result of the optimization is subject to the same +-- optimization, /and/ the rest of the optimizations. If there is no match +-- then the optimization should call the 'next' continuation to pass the +-- stream to the next optimization in the optimization chain. We then define +-- the last "optimization" to be @tailLoop@ which selects the next block of +-- code to optimize and begin the optimization pipeline again. +----------------------------------------------------------------------------- +module GHC.JS.Optimizer + ( jsOptimize + ) where + + +import Prelude + +import GHC.JS.Syntax + +import Control.Arrow + +{- +Note [ Unsafe JavaScript Optimizations ] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of optimizations that the JavaScript Backend performs that +are not sound with respect to arbritrary JavaScript. We still perform these +optimizations because we are not optimizing arbritrary javascript and under the +assumption that the JavaScript backend will not generate code that violates the +soundness of the optimizer. For example, the @deadCodeElim@ optimization removes +all statements that occur after a 'return' in JavaScript, however this is not +always sound because of hoisting, consider this program: + + function foo() { + var x = 2; + bar(); + return x; + + function bar() { + x = 10; + }} + + which is transformed to: + + function foo() { + var x = 2; + bar(); + return x; + }} + +The optimized form is clearly a program that goes wrong because `bar()` is no +longer defined. But the JavaScript backend will never generate this code, so as +long as that assumption holds we are safe to perform optimizations that would +normally be unsafe. +-} + + +-------------------------------------------------------------------------------- +-- Top level Driver +-------------------------------------------------------------------------------- +jsOptimize :: JStat -> JStat +jsOptimize = go + where + p_opt = jsOptimize + opt = jsOptimize' + e_opt = jExprOptimize + -- base case + go (BlockStat xs) = BlockStat (opt xs) + -- recursive cases + go (ForStat i p s body) = ForStat (go i) (e_opt p) (go s) (p_opt body) + go (ForInStat b i p body) = ForInStat b i p (p_opt body) + go (WhileStat b c body) = WhileStat b (e_opt c) (p_opt body) + go (SwitchStat s ps body) = SwitchStat s (fmap (second go) ps) (p_opt body) + go (FuncStat i args body) = FuncStat i args (p_opt body) + go (IfStat c t e) = IfStat (e_opt c) (p_opt t) (p_opt e) + go (TryStat ths i c f) = TryStat (p_opt ths) i (p_opt c) (p_opt f) + go (LabelStat lbl s) = LabelStat lbl (p_opt s) + -- special case: drive the optimizer into expressions + go (AssignStat id op rhs) = AssignStat (e_opt id) op (e_opt rhs) + go (DeclStat i (Just e)) = DeclStat i (Just $ e_opt e) + go (ReturnStat e) = ReturnStat (e_opt e) + go (UOpStat op e) = UOpStat op (e_opt e) + go (ApplStat f args) = ApplStat (e_opt f) (e_opt <$> args) + -- all else is terminal, we match on these to force a warning in the event + -- another constructor is added + go x at BreakStat{} = x + go x at ContinueStat{} = x + go x at DeclStat{} = x -- match on the nothing case + +jsOptimize' :: [JStat] -> [JStat] +jsOptimize' = runBlockOpt opts . single_pass_opts + where + opts :: BlockOpt + opts = safe_opts + <> unsafe_opts + <> tailLoop -- tailloop must be last, see module description + + unsafe_opts :: BlockOpt + unsafe_opts = mconcat [ deadCodeElim ] + + safe_opts :: BlockOpt + safe_opts = mconcat [ declareAssign, combineOps ] + + single_pass_opts :: BlockTrans + single_pass_opts = runBlockTrans sp_opts + + sp_opts = [flattenBlocks] + +-- | recur over a @JExpr@ and optimize the @JVal at s +jExprOptimize :: JExpr -> JExpr +-- the base case +jExprOptimize (ValExpr val) = ValExpr (jValOptimize val) +-- recursive cases +jExprOptimize (SelExpr obj field) = SelExpr (jExprOptimize obj) field +jExprOptimize (IdxExpr obj ix) = IdxExpr (jExprOptimize obj) (jExprOptimize ix) +jExprOptimize (UOpExpr op exp) = UOpExpr op (jExprOptimize exp) +jExprOptimize (IfExpr c t e) = IfExpr c (jExprOptimize t) (jExprOptimize e) +jExprOptimize (ApplExpr f args ) = ApplExpr (jExprOptimize f) (jExprOptimize <$> args) +jExprOptimize (InfixExpr op l r) = InfixExpr op (jExprOptimize l) (jExprOptimize r) + +-- | drive optimizations to anonymous functions and over expressions +jValOptimize :: JVal -> JVal +-- base case +jValOptimize (JFunc args body) = JFunc args (jsOptimize body) +-- recursive cases +jValOptimize (JList exprs) = JList (jExprOptimize <$> exprs) +jValOptimize (JHash hash) = JHash (jExprOptimize <$> hash) +-- all else is terminal +jValOptimize x at JVar{} = x +jValOptimize x at JDouble{} = x +jValOptimize x at JInt{} = x +jValOptimize x at JStr{} = x +jValOptimize x at JRegEx{} = x + +-- | A block transformation is a function from a stream of syntax to another +-- stream +type BlockTrans = [JStat] -> [JStat] + +-- | A BlockOpt is a function that alters the stream, and a continuation that +-- represents the rest of the stream. The first @BlockTrans@ represents +-- restarting the optimizer after a change has happened. The second @BlockTrans@ +-- represents the rest of the continuation stream. +newtype BlockOpt = BlockOpt (BlockTrans -> BlockTrans -> BlockTrans) + +-- | To merge two BlockOpt we first run the left-hand side optimization and +-- capture the right-hand side in the continuation +instance Semigroup BlockOpt where + BlockOpt opt0 <> BlockOpt opt1 = BlockOpt + $ \loop next -> opt0 loop (opt1 loop next) + +instance Monoid BlockOpt where + -- don't loop, just finalize + mempty = BlockOpt $ \_loop next -> next + +-- | loop until a fixpoint is reached +runBlockOpt :: BlockOpt -> [JStat] -> [JStat] +runBlockOpt (BlockOpt opt) xs = recur xs + where recur = opt recur id + +runBlockTrans :: [BlockTrans] -> [JStat] -> [JStat] +runBlockTrans opts = foldl (.) id opts + +-- | Perform all the optimizations on the tail of a block. +tailLoop :: BlockOpt +tailLoop = BlockOpt $ \loop next -> \case + [] -> next [] + -- this call to jsOptimize is required or else the optimizer will not + -- properly recur down JStat. See the 'deadCodeElim' test for examples which + -- were failing before this change + (x:xs) -> next (jsOptimize x : loop xs) + +-------------------------------------------------------------------------------- +-- Single Slot Optimizations +-------------------------------------------------------------------------------- + +{- | + Catch modify and assign operators: + case 1: + i = i + 1; ==> ++i; + case 2: + i = i - 1; ==> --i; + case 3: + i = i + n; ==> i += n; + case 4: + i = i - n; ==> i -= n; +-} +combineOps :: BlockOpt +combineOps = BlockOpt $ \loop next -> + \case + -- find a op pattern, and rerun the optimizer on its result unless there is + -- nothing to optimize, in which case call the next optimization + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op (ValExpr (JVar i')) e)) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- commutative cases + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op e (ValExpr (JVar i')))) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- general case, we had nothing to optimize in this case so call the next + -- optimization + xs -> next xs + + +-------------------------------------------------------------------------------- +-- Dual Slot Optimizations +-------------------------------------------------------------------------------- +-- | Catch 'var i; i = q;' ==> 'var i = q;' +declareAssign :: BlockOpt +declareAssign = BlockOpt $ + \loop next -> \case + ( (DeclStat i Nothing) + : (AssignStat (ValExpr (JVar i')) AssignOp v) + : xs + ) | i == i' -> loop (DeclStat i (Just v) : xs) + xs -> next xs + +-- | Eliminate all code after a return statement. This is a special case +-- optimization that doesn't need to loop. See Note [Unsafe JavaScript +-- optimizations] +deadCodeElim :: BlockOpt +deadCodeElim = BlockOpt $ + \_loop next -> \case + (x at ReturnStat{}:_) -> next [x] + xs -> next xs + +-- | remove nested blocks +flattenBlocks :: BlockTrans +flattenBlocks (BlockStat y : ys) = flattenBlocks y ++ flattenBlocks ys +flattenBlocks (x:xs) = x : flattenBlocks xs +flattenBlocks [] = [] ===================================== compiler/GHC/JS/Ppr.hs ===================================== @@ -10,10 +10,46 @@ -- For Outputable instances for JS syntax {-# OPTIONS_GHC -Wno-orphans #-} --- | Pretty-printing JavaScript +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Ppr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Ppr defines the code generation facilities for the JavaScript +-- backend. That is, this module exports a function from the JS backend IR +-- to JavaScript compliant concrete syntax that can readily be executed by +-- nodejs or called in a browser. +-- +-- * Design +-- +-- This module follows the architecture and style of the other backends in +-- GHC: it intances Outputable for the relevant types, creates a class that +-- describes a morphism from the IR domain to JavaScript concrete Syntax and +-- then generates that syntax on a case by case basis. +-- +-- * How to use +-- +-- The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record. +-- Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for +-- specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a +-- custom renderer ensures all @Ident@ generated by the linker optimization +-- pass are prefixed differently than the default. Use @renderJS@ to +-- generate JavaScript concrete syntax in the general case, suitable for +-- human consumption. +----------------------------------------------------------------------------- + module GHC.JS.Ppr ( renderJs - , renderJs' , renderPrefixJs , renderPrefixJs' , JsToDoc(..) @@ -21,9 +57,10 @@ module GHC.JS.Ppr , RenderJs(..) , jsToDoc , pprStringLit - , flattenBlocks , braceNest , hangBrace + , interSemi + , addSemi ) where @@ -49,9 +86,9 @@ instance Outputable JExpr where instance Outputable JVal where ppr = docToSDoc . renderJs - -($$$) :: Doc -> Doc -> Doc -x $$$ y = nest 2 $ x $+$ y +-------------------------------------------------------------------------------- +-- Top level API +-------------------------------------------------------------------------------- -- | Render a syntax tree as a pretty-printable document -- (simply showing the resultant doc produces a nice, @@ -84,26 +121,17 @@ renderPrefixJs = renderPrefixJs' defaultRenderJs renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc renderPrefixJs' r = jsToDocR r -braceNest :: Doc -> Doc -braceNest x = char '{' <+> nest 2 x $$ char '}' - --- | Hang with braces: --- --- hdr { --- body --- } -hangBrace :: Doc -> Doc -> Doc -hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] +-------------------------------------------------------------------------------- +-- Code Generator +-------------------------------------------------------------------------------- class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc -instance JsToDoc JStat where jsToDocR r = renderJsS r r -instance JsToDoc JExpr where jsToDocR r = renderJsE r r -instance JsToDoc JVal where jsToDocR r = renderJsV r r -instance JsToDoc Ident where jsToDocR r = renderJsI r r -instance JsToDoc [JExpr] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) -instance JsToDoc [JStat] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc JStat where jsToDocR r = renderJsS r r +instance JsToDoc JExpr where jsToDocR r = renderJsE r r +instance JsToDoc JVal where jsToDocR r = renderJsV r r +instance JsToDoc Ident where jsToDocR r = renderJsI r r +instance JsToDoc [JExpr] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc [JStat] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r) defRenderJsS :: RenderJs -> JStat -> Doc defRenderJsS r = \case @@ -120,12 +148,16 @@ defRenderJsS r = \case ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s where - printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss + printBS (BlockStat ss) = vcat $ interSemi $ map (jsToDocR r) ss printBS x = jsToDocR r x - interSemi [x] = [jsToDocR r x] - interSemi [] = [] - interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs + ForStat init p s1 sb -> hangBrace (text "for" <> forCond) (jsToDocR r sb) + where + forCond = parens $ hcat $ interSemi + [ jsToDocR r init + , jsToDocR r p + , parens (jsToDocR r s1) + ] ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b) where txt | each = "for each" | otherwise = "for" @@ -134,12 +166,15 @@ defRenderJsS r = \case cases = vcat l' ReturnStat e -> text "return" <+> jsToDocR r e ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es) + FuncStat i is b -> hangBrace (text "function" <+> jsToDocR r i + <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) + (jsToDocR r b) TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally where mbCatch | s1 == BlockStat [] = PP.empty | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1) mbFinally | s2 == BlockStat [] = PP.empty | otherwise = hangBrace (text "finally") (jsToDocR r s2) - AssignStat i x -> case x of + AssignStat i op x -> case x of -- special treatment for functions, otherwise there is too much left padding -- (more than the length of the expression assigned to). E.g. -- @@ -148,19 +183,13 @@ defRenderJsS r = \case -- ... -- }); -- - ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] - _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x + ValExpr (JFunc is b) -> sep [jsToDocR r i <+> ftext (aOpText op) <+> text " function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] + _ -> jsToDocR r i <+> ftext (aOpText op) <+> jsToDocR r x UOpStat op x | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x | isPre op -> ftext (uOpText op) <> optParens r x | otherwise -> optParens r x <> ftext (uOpText op) - BlockStat xs -> jsToDocR r (flattenBlocks xs) - -flattenBlocks :: [JStat] -> [JStat] -flattenBlocks = \case - BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys - y:ys -> y : flattenBlocks ys - [] -> [] + BlockStat xs -> jsToDocR r xs optParens :: RenderJs -> JExpr -> Doc optParens r x = case x of @@ -204,33 +233,12 @@ defRenderJsV r = \case defRenderJsI :: RenderJs -> Ident -> Doc defRenderJsI _ (TxtI t) = ftext t +aOpText :: AOp -> FastString +aOpText = \case + AssignOp -> "=" + AddAssignOp -> "+=" + SubAssignOp -> "-=" -pprStringLit :: FastString -> Doc -pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] - -encodeJson :: FastString -> Doc -encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) - -encodeJsonChar :: Char -> Doc -encodeJsonChar = \case - '/' -> text "\\/" - '\b' -> text "\\b" - '\f' -> text "\\f" - '\n' -> text "\\n" - '\r' -> text "\\r" - '\t' -> text "\\t" - '"' -> text "\\\"" - '\\' -> text "\\\\" - c - | not (isControl c) && ord c <= 127 -> char c - | ord c <= 0xff -> hexxs "\\x" 2 (ord c) - | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) - | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair - in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> - hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) - where hexxs prefix pad cp = - let h = showHex cp "" - in text (prefix ++ replicate (pad - length h) '0' ++ h) uOpText :: UOp -> FastString uOpText = \case @@ -289,3 +297,56 @@ isAlphaOp = \case YieldOp -> True VoidOp -> True _ -> False + +pprStringLit :: FastString -> Doc +pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +encodeJson :: FastString -> Doc +encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) + +encodeJsonChar :: Char -> Doc +encodeJsonChar = \case + '/' -> text "\\/" + '\b' -> text "\\b" + '\f' -> text "\\f" + '\n' -> text "\\n" + '\r' -> text "\\r" + '\t' -> text "\\t" + '"' -> text "\\\"" + '\\' -> text "\\\\" + c + | not (isControl c) && ord c <= 127 -> char c + | ord c <= 0xff -> hexxs "\\x" 2 (ord c) + | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) + | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair + in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> + hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) + where hexxs prefix pad cp = + let h = showHex cp "" + in text (prefix ++ replicate (pad - length h) '0' ++ h) + +braceNest :: Doc -> Doc +braceNest x = char '{' <+> nest 2 x $$ char '}' + +interSemi :: [Doc] -> [Doc] +interSemi [] = [] +interSemi [s] = [s] +interSemi (x:xs) = x <> text ";" : interSemi xs + +addSemi :: Doc -> Doc +addSemi x = x <> text ";" + +-- | Hang with braces: +-- +-- hdr { +-- body +-- } +hangBrace :: Doc -> Doc -> Doc +hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] + +($$$) :: Doc -> Doc -> Doc +x $$$ y = nest 2 $ x $+$ y ===================================== compiler/GHC/JS/Syntax.hs ===================================== @@ -58,6 +58,7 @@ module GHC.JS.Syntax , JVal(..) , Op(..) , UOp(..) + , AOp(..) , Ident(..) , JLabel -- * pattern synonyms over JS operators @@ -110,20 +111,22 @@ import GHC.Generics -- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) -- for details data JStat - = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] - | ReturnStat JExpr -- ^ Return - | IfStat JExpr JStat JStat -- ^ If + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForStat JStat JExpr JStat JStat -- ^ For | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch | TryStat JStat Ident JStat JStat -- ^ Try - | BlockStat [JStat] -- ^ Blocks - | ApplStat JExpr [JExpr] -- ^ Application - | UOpStat UOp JExpr -- ^ Unary operators - | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ - | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic - | BreakStat (Maybe JLabel) -- ^ Break - | ContinueStat (Maybe JLabel) -- ^ Continue + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat UOp JExpr -- ^ Unary operators + | AssignStat JExpr AOp JExpr -- ^ Binding form: @ @ + | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JLabel) -- ^ Break + | ContinueStat (Maybe JLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition deriving (Eq, Typeable, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of @@ -146,9 +149,9 @@ appendJStat mx my = case (mx,my) of (BlockStat [] , y ) -> y (x , BlockStat []) -> x (BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys - (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] - (xs , BlockStat ys) -> BlockStat $! xs : ys - (xs , ys ) -> BlockStat [xs,ys] + (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $! xs : ys + (xs , ys ) -> BlockStat [xs,ys] -------------------------------------------------------------------------------- @@ -156,13 +159,13 @@ appendJStat mx my = case (mx,my) of -------------------------------------------------------------------------------- -- | JavaScript Expressions data JExpr - = ValExpr JVal -- ^ All values are trivially expressions - | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' - | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' - | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms - | UOpExpr UOp JExpr -- ^ Unary Expressions + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms + | UOpExpr UOp JExpr -- ^ Unary Expressions | IfExpr JExpr JExpr JExpr -- ^ If-expression - | ApplExpr JExpr [JExpr] -- ^ Application + | ApplExpr JExpr [JExpr] -- ^ Application deriving (Eq, Typeable, Generic) -- * Useful pattern synonyms to ease programming with the deeply embedded JS @@ -321,6 +324,15 @@ data UOp instance NFData UOp +-- | JS Unary Operators +data AOp + = AssignOp -- ^ Vanilla Assignment: = + | AddAssignOp -- ^ Addition Assignment: += + | SubAssignOp -- ^ Subtraction Assignment: -= + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData AOp + -- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' -- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on -- Sane-ness @@ -345,10 +357,12 @@ instance Show SaneDouble where -------------------------------------------------------------------------------- jassignAllEqual :: [JExpr] -> [JExpr] -> JStat -jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" AssignStat xs ys) +jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" go xs ys) + where go l r = AssignStat l AssignOp r jassignAll :: [JExpr] -> [JExpr] -> JStat -jassignAll xs ys = mconcat (zipWith AssignStat xs ys) +jassignAll xs ys = mconcat $ zipWith go xs ys + where go l r = AssignStat l AssignOp r jvar :: FastString -> JExpr jvar = ValExpr . JVar . TxtI ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -47,6 +47,7 @@ identsS = \case Sat.ReturnStat e -> identsE e Sat.IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 Sat.WhileStat _ e s -> identsE e ++ identsS s + Sat.ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body Sat.ForInStat _ i e s -> [i] ++ identsE e ++ identsS s Sat.SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s where traverseCase (e,s) = identsE e ++ identsS s @@ -54,10 +55,11 @@ identsS = \case Sat.BlockStat xs -> concatMap identsS xs Sat.ApplStat e es -> identsE e ++ concatMap identsE es Sat.UOpStat _op e -> identsE e - Sat.AssignStat e1 e2 -> identsE e1 ++ identsE e2 + Sat.AssignStat e1 _op e2 -> identsE e1 ++ identsE e2 Sat.LabelStat _l s -> identsS s Sat.BreakStat{} -> [] Sat.ContinueStat{} -> [] + Sat.FuncStat i args body -> [i] ++ args ++ identsS body {-# INLINE identsE #-} identsE :: Sat.JExpr -> [Ident] @@ -148,6 +150,8 @@ jmcompos ret app f' v = ReturnStat i -> ret ReturnStat `app` f i IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s' WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s + ForStat init p step body -> ret ForStat `app` f init `app` f p + `app` f step `app` f body ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l @@ -158,6 +162,7 @@ jmcompos ret app f' v = AssignStat e e' -> ret AssignStat `app` f e `app` f e' UnsatBlock _ -> ret v' ContinueStat l -> ret (ContinueStat l) + FuncStat i args body -> ret FuncStat `app` f i `app` mapM' f args `app` f body BreakStat l -> ret (BreakStat l) LabelStat l s -> ret (LabelStat l) `app` f s JMGExpr v' -> ret JMGExpr `app` case v' of @@ -217,7 +222,6 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) -------------------------------------------------------------------------------- -- Translation -- --- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- satJStat :: JStat -> Sat.JStat satJStat = witness . proof @@ -229,6 +233,9 @@ satJStat = witness . proof witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) + witness (ForStat init p step body) = Sat.ForStat + (witness init) (satJExpr p) + (witness step) (witness body) witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i (satJExpr iter) (witness body) @@ -240,12 +247,13 @@ satJStat = witness . proof witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) + witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) Sat.AssignOp (satJExpr rhs) witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) witness (BreakStat Nothing) = Sat.BreakStat Nothing witness (BreakStat (Just l)) = Sat.BreakStat $! Just l witness (ContinueStat Nothing) = Sat.ContinueStat Nothing witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l + witness (FuncStat i args body) = Sat.FuncStat i args (witness body) witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" ===================================== compiler/GHC/JS/Unsat/Syntax.hs ===================================== @@ -146,6 +146,7 @@ data JStat | ReturnStat JExpr -- ^ Return | IfStat JExpr JStat JStat -- ^ If | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForStat JStat JExpr JStat JStat -- ^ For | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch | TryStat JStat Ident JStat JStat -- ^ Try @@ -157,6 +158,7 @@ data JStat | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic | BreakStat (Maybe JsLabel) -- ^ Break | ContinueStat (Maybe JsLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition deriving (Eq, Typeable, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of ===================================== compiler/GHC/StgToJS/Apply.hs ===================================== @@ -408,17 +408,11 @@ mkApplyArr = mconcat [ TxtI "h$apply" ||= toJExpr (JList []) , TxtI "h$paps" ||= toJExpr (JList []) , ApplStat (var "h$initStatic" .^ "push") - [ ValExpr $ JFunc [] $ jVar \i -> mconcat - [ i |= zero_ - , WhileStat False (i .<. Int 65536) $ mconcat - [ var "h$apply" .! i |= var "h$ap_gen" - , preIncrS i - ] - , i |= zero_ - , WhileStat False (i .<. Int 128) $ mconcat - [ var "h$paps" .! i |= var "h$pap_gen" - , preIncrS i - ] + [ ValExpr $ JFunc [] $ mconcat + [ jFor (|= zero_) (.<. Int 65536) preIncrS + (\j -> var "h$apply" .! j |= var "h$ap_gen") + , jFor (|= zero_) (.<. Int 128) preIncrS + (\j -> var "h$paps" .! j |= var "h$pap_gen") , mconcat (map assignSpec applySpec) , mconcat (map assignPap specPap) ] ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -16,6 +16,7 @@ import GHC.JS.Ppr import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Arg import GHC.StgToJS.Sinker @@ -133,10 +134,10 @@ genUnits m ss spt_entries foreign_stubs = do glbl <- State.gets gsGlobal staticInit <- initStaticPtrs spt_entries - let stat = ( -- O.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m 1) - $ mconcat (reverse glbl) <> staticInit) + let stat = ( jsOptimize + . satJStat + . jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] let oi = ObjUnit { oiSymbols = syms @@ -208,7 +209,9 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsOptimize + . satJStat + $ jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -245,10 +248,10 @@ genUnits m ss spt_entries foreign_stubs = do let allDeps = collectIds unf decl topDeps = collectTopIds decl required = hasExport decl - stat = -- Opt.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m n) - $ mconcat (reverse extraTl) <> tl + stat = jsOptimize + . satJStat + . jsSaturate (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps let oi = ObjUnit { oiSymbols = syms @@ -308,15 +311,15 @@ genSetConInfo i d l {- srt -} = do (fixedLayout $ map uTypeVt fields) (CICon $ dataConTag d) sr - return (ei ||= mkDataEntry) + return (mkDataEntry ei) where -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug? fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing) (dataConRepArgTys d) -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d) -mkDataEntry :: JExpr -mkDataEntry = ValExpr $ JFunc [] returnStack +mkDataEntry :: Ident -> JStat +mkDataEntry i = FuncStat i [] returnStack genToplevelRhs :: Id -> CgStgRhs -> G JStat -- general cases: ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -240,7 +240,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = body <- genBody ctx R1 args body typ ei@(TxtI eii) <- identForEntryId i sr <- genStaticRefsRhs rhs - let f = JFunc [] (bh <> lvs <> body) + let f = (bh <> lvs <> body) emitClosureInfo $ ClosureInfo ei (CIRegs 0 $ concatMap idVt args) @@ -249,7 +249,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = map (stackSlotType . fst) (ctxLneFrameVars ctx)) CIStackFrame sr - emitToplevel (ei ||= toJExpr f) + emitToplevel (jFunction ei [] f) genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do let payloadSize = ctxLneFrameSize ctx ei@(TxtI _eii) <- identForEntryId i @@ -258,8 +258,7 @@ genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do p <- popLneFrame True payloadSize ctx args' <- concatMapM genArg args ac <- allocCon ii con cc args' - emitToplevel (ei ||= toJExpr (JFunc [] - (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack]))) + emitToplevel (jFunction ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])) -- | Generate the entry function for a local closure genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () @@ -283,7 +282,7 @@ genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) = (fixedLayout $ map (uTypeVt . idType) live) et sr - emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + emitToplevel (jFunction ei [] (mconcat [ll, llv, upd, setcc, body])) where entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) @@ -630,7 +629,7 @@ genRet ctx e at as l = freshIdent >>= f ++ if prof then [ObjV] else map stackSlotType lneVars) CIStackFrame sr - emitToplevel $ r ||= toJExpr (JFunc [] fun') + emitToplevel $ jFunction r [] fun' return (pushLne <> saveCCS <> pushRet) fst3 ~(x,_,_) = x ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -30,6 +30,7 @@ import Prelude import GHC.Platform.Host (hostPlatformArchOS) import GHC.JS.Make +import GHC.JS.Optimizer import GHC.JS.Unsat.Syntax import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform @@ -43,11 +44,11 @@ import GHC.Linker.Static.Utils (exeFileName) import GHC.StgToJS.Linker.Types import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Linker.Opt import GHC.StgToJS.Rts.Rts import GHC.StgToJS.Object import GHC.StgToJS.Types hiding (LinkableUnit) import GHC.StgToJS.Symbols -import GHC.StgToJS.Printer import GHC.StgToJS.Arg import GHC.StgToJS.Closure @@ -332,7 +333,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsOptimize $ satJStat meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Printer.hs → compiler/GHC/StgToJS/Linker/Opt.hs ===================================== @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | --- Module : GHC.StgToJS.Printer +-- Module : GHC.StgToJS.Linker.Opt -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE) -- @@ -13,15 +13,14 @@ -- Sylvain Henry -- Stability : experimental -- --- Custom prettyprinter for JS AST uses the JS PPr module for most of --- the work +-- Optimization pass at link time +-- -- -- ----------------------------------------------------------------------------- -module GHC.StgToJS.Printer +module GHC.StgToJS.Linker.Opt ( pretty , ghcjsRenderJs - , prettyBlock ) where @@ -93,8 +92,7 @@ hexDoc v = text $ go v -- attempt to resugar some of the common constructs ghcjsRenderJsS :: RenderJs -> JStat -> Doc -ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) -ghcjsRenderJsS r s = renderJsS defaultRenderJs r s +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s -- don't quote keys in our object literals, so closure compiler works ghcjsRenderJsV :: RenderJs -> JVal -> Doc @@ -120,97 +118,3 @@ ghcjsRenderJsV r (JHash m) validOtherIdent c = isAlpha c || isDigit c ghcjsRenderJsV r v = renderJsV defaultRenderJs r v - -prettyBlock :: RenderJs -> [JStat] -> Doc -prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs) - --- recognize common patterns in a block and convert them to more idiomatic/concise javascript -prettyBlock' :: RenderJs -> [JStat] -> [Doc] --- return/... -prettyBlock' r ( x@(ReturnStat _) - : xs - ) - | not (null xs) - = prettyBlock' r [x] --- declare/assign -prettyBlock' r ( (DeclStat i Nothing) - : (AssignStat (ValExpr (JVar i')) v) - : xs - ) - | i == i' - = prettyBlock' r (DeclStat i (Just v) : xs) - --- resugar for loops with/without var declaration -prettyBlock' r ( (DeclStat i (Just v0)) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs - --- global function (does not preserve semantics but works for GHCJS) -prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b)))) - : xs - ) - = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) - (jsToDocR r b) - ) : prettyBlock' r xs --- modify/assign operators -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs - - -prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs -prettyBlock' _ [] = [] - --- build the for block -mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc -mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond) - (jsToDocR r $ BlockStat sb) - where - c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0 - | otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0 - forCond = parens $ hcat $ interSemi - [ c0 - , jsToDocR r p - , parens (jsToDocR r s1) - ] - --- check if a statement is suitable to be converted to something in the for(;;x) position -isForUpdStat :: JStat -> Bool -isForUpdStat UOpStat {} = True -isForUpdStat AssignStat {} = True -isForUpdStat ApplStat {} = True -isForUpdStat _ = False - -interSemi :: [Doc] -> [Doc] -interSemi [] = [PP.empty] -interSemi [s] = [s] -interSemi (x:xs) = x <> text ";" : interSemi xs - -addSemi :: Doc -> Doc -addSemi x = x <> text ";" ===================================== compiler/GHC/StgToJS/Object.hs ===================================== @@ -408,31 +408,35 @@ instance Binary Sat.JStat where put_ bh (Sat.ReturnStat e) = putByte bh 2 >> put_ bh e put_ bh (Sat.IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 put_ bh (Sat.WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s - put_ bh (Sat.ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s - put_ bh (Sat.SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s - put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 - put_ bh (Sat.BlockStat xs) = putByte bh 8 >> put_ bh xs - put_ bh (Sat.ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es - put_ bh (Sat.UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e - put_ bh (Sat.AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 - put_ bh (Sat.LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s - put_ bh (Sat.BreakStat ml) = putByte bh 13 >> put_ bh ml - put_ bh (Sat.ContinueStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ForStat is c s bd) = putByte bh 5 >> put_ bh is >> put_ bh c >> put_ bh s >> put_ bh bd + put_ bh (Sat.ForInStat b i e s) = putByte bh 6 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (Sat.SwitchStat e ss s) = putByte bh 7 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 8 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (Sat.BlockStat xs) = putByte bh 9 >> put_ bh xs + put_ bh (Sat.ApplStat e es) = putByte bh 10 >> put_ bh e >> put_ bh es + put_ bh (Sat.UOpStat o e) = putByte bh 11 >> put_ bh o >> put_ bh e + put_ bh (Sat.AssignStat e1 op e2) = putByte bh 12 >> put_ bh e1 >> put_ bh op >> put_ bh e2 + put_ bh (Sat.LabelStat l s) = putByte bh 13 >> put_ bh l >> put_ bh s + put_ bh (Sat.BreakStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ContinueStat ml) = putByte bh 15 >> put_ bh ml + put_ bh (Sat.FuncStat i is b) = putByte bh 16 >> put_ bh i >> put_ bh is >> put_ bh b get bh = getByte bh >>= \case 1 -> Sat.DeclStat <$> get bh <*> get bh 2 -> Sat.ReturnStat <$> get bh 3 -> Sat.IfStat <$> get bh <*> get bh <*> get bh 4 -> Sat.WhileStat <$> get bh <*> get bh <*> get bh - 5 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh - 6 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh - 7 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh - 8 -> Sat.BlockStat <$> get bh - 9 -> Sat.ApplStat <$> get bh <*> get bh - 10 -> Sat.UOpStat <$> get bh <*> get bh - 11 -> Sat.AssignStat <$> get bh <*> get bh - 12 -> Sat.LabelStat <$> get bh <*> get bh - 13 -> Sat.BreakStat <$> get bh - 14 -> Sat.ContinueStat <$> get bh + 5 -> Sat.ForStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 7 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh + 8 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 9 -> Sat.BlockStat <$> get bh + 10 -> Sat.ApplStat <$> get bh <*> get bh + 11 -> Sat.UOpStat <$> get bh <*> get bh + 12 -> Sat.AssignStat <$> get bh <*> get bh <*> get bh + 13 -> Sat.LabelStat <$> get bh <*> get bh + 14 -> Sat.BreakStat <$> get bh + 15 -> Sat.ContinueStat <$> get bh + 16 -> Sat.FuncStat <$> get bh <*> get bh <*> get bh n -> error ("Binary get bh JStat: invalid tag: " ++ show n) @@ -541,6 +545,10 @@ instance Binary Sat.UOp where put_ bh = putEnum bh get bh = getEnum bh +instance Binary Sat.AOp where + put_ bh = putEnum bh + get bh = getEnum bh + -- 16 bit sizes should be enough... instance Binary CILayout where put_ bh CILayoutVariable = putByte bh 1 ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,16 +30,18 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Apply import GHC.StgToJS.Closure import GHC.StgToJS.Heap -import GHC.StgToJS.Printer import GHC.StgToJS.Profiling import GHC.StgToJS.Regs import GHC.StgToJS.Types import GHC.StgToJS.Stack +import GHC.StgToJS.Linker.Opt + import GHC.Data.FastString import GHC.Types.Unique.Map @@ -134,7 +136,7 @@ closureConstructors s = BlockStat | otherwise = mempty mkClosureCon :: Maybe Int -> JStat - mkClosureCon n0 = funName ||= toJExpr fun + mkClosureCon n0 = jFunction funName args funBod where n | Just n' <- n0 = n' | Nothing <- n0 = 0 @@ -142,7 +144,6 @@ closureConstructors s = BlockStat | Nothing <- n0 = TxtI $ mkFastString "h$c" -- args are: f x1 x2 .. xn [cc] args = TxtI "f" : addCCArg' (map varName [1..n]) - fun = JFunc args funBod -- x1 goes into closureField1. All the other args are bundled into an -- object in closureField2: { d1 = x2, d2 = x3, ... } -- @@ -157,12 +158,12 @@ closureConstructors s = BlockStat ] mkDataFill :: Int -> JStat - mkDataFill n = funName ||= toJExpr fun + mkDataFill n = jFunction funName (map TxtI ds) body where funName = TxtI $ dataName n ds = map dataFieldName [1..n] extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds - fun = JFunc (map TxtI ds) (checkD <> returnS extra_args) + body = (checkD <> returnS extra_args) -- | JS Payload to perform stack manipulation in the RTS stackManip :: JStat @@ -172,10 +173,10 @@ stackManip = mconcat (map mkPush [1..32]) <> mkPush :: Int -> JStat mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) as = map varName [1..n] - fun = JFunc as ((sp |= sp + toJExpr n) - <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) - [1..] as)) - in funName ||= toJExpr fun + body = ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + [1..] as)) + in jFunction funName as body -- partial pushes, based on bitmap, increases Sp by highest bit mkPpush :: Integer -> JStat @@ -185,11 +186,10 @@ stackManip = mconcat (map mkPush [1..32]) <> n = length bits h = last bits args = map varName [1..n] - fun = JFunc args $ - mconcat [ sp |= sp + toJExpr (h+1) - , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) - ] - in funName ||= toJExpr fun + body = mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) + ] + in jFunction funName args body bitsIdx :: Integer -> [Int] bitsIdx n | n < 0 = error "bitsIdx: negative" @@ -244,12 +244,12 @@ loadRegs :: JStat loadRegs = mconcat $ map mkLoad [1..32] where mkLoad :: Int -> JStat - mkLoad n = let args = map varName [1..n] - assign = zipWith (\a r -> toJExpr r |= toJExpr a) - args (reverse $ take n regsFromR1) - fname = TxtI $ mkFastString ("h$l" ++ show n) - fun = JFunc args (mconcat assign) - in fname ||= toJExpr fun + mkLoad n = let args = map varName [1..n] + body = mconcat $ + zipWith (\a r -> toJExpr r |= toJExpr a) + args (reverse $ take n regsFromR1) + fname = TxtI $ mkFastString ("h$l" ++ show n) + in jFunction fname args body -- | Assign registers R1 ... Rn in descending order, that is assign Rn first. -- This function uses the 'assignRegs'' array to construct functions which set @@ -314,11 +314,11 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . jsOptimize . satJStat . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty . jsOptimize . satJStat $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' rts :: StgToJSConfig -> JStat ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -719,6 +719,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "NoUnitIdMatching" = 51294 GhcDiagnosticCode "NotAModule" = 35235 GhcDiagnosticCode "Can'tFindNameInInterface" = 83249 + GhcDiagnosticCode "CircularImport" = 75429 GhcDiagnosticCode "HiModuleNameMismatchWarn" = 53693 GhcDiagnosticCode "ExceptionOccurred" = 47808 ===================================== compiler/ghc.cabal.in ===================================== @@ -532,6 +532,7 @@ Library GHC.IfaceToCore GHC.Iface.Type GHC.JS.Make + GHC.JS.Optimizer GHC.JS.Ppr GHC.JS.Syntax GHC.JS.Transform @@ -672,7 +673,6 @@ Library GHC.StgToJS.Object GHC.StgToJS.Prim GHC.StgToJS.Profiling - GHC.StgToJS.Printer GHC.StgToJS.Regs GHC.StgToJS.Rts.Types GHC.StgToJS.Rts.Rts @@ -686,6 +686,7 @@ Library GHC.StgToJS.Linker.Linker GHC.StgToJS.Linker.Types GHC.StgToJS.Linker.Utils + GHC.StgToJS.Linker.Opt GHC.Stg.Unarise GHC.SysTools GHC.SysTools.Ar ===================================== testsuite/tests/javascript/opt/all.T ===================================== @@ -0,0 +1,4 @@ +# These are JavaScript-specific tests for the JS backend optimizer +setTestOpts(when(not(js_arch()),skip)) + +test('deadCodeElim', normal, compile_and_run, ['-package ghc']) ===================================== testsuite/tests/javascript/opt/deadCodeElim.hs ===================================== @@ -0,0 +1,96 @@ + +import GHC.JS.Optimizer +import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax (Ident (..)) + +import GHC.Data.FastString + +double_return :: JStat +double_return = BlockStat [ ReturnStat (SatInt 0) + , ReturnStat (SatInt 1) + ] + +double_return_opt :: JStat +double_return_opt = (BlockStat [ReturnStat (SatInt 0)]) + +in_func :: JStat +in_func = AssignStat (jvar (fsLit "foo")) AssignOp (ValExpr (JFunc [] double_return)) + +in_func_opt :: JStat +in_func_opt = AssignStat (jvar (fsLit "foo")) AssignOp (ValExpr (JFunc [] double_return_opt)) + +nested_blocks :: JStat +nested_blocks = BlockStat [ double_return <> double_return + , double_return + ] <> double_return + +nested_blocks_opt :: JStat +nested_blocks_opt = double_return_opt + +global_func :: JStat +global_func = FuncStat (TxtI (fsLit "bar")) [] double_return + +global_func_opt :: JStat +global_func_opt = FuncStat (TxtI (fsLit "bar")) [] double_return_opt + +func_with_locals :: JStat +func_with_locals = AssignStat (jvar (fsLit "foo")) + AssignOp + (ValExpr (JFunc [] + (BlockStat [ AssignStat (jvar (fsLit "one")) AssignOp (SatInt 2) + , AssignStat (jvar (fsLit "two")) AssignOp (SatInt 3) + , ApplStat (jvar (fsLit "f")) [(SatInt 100)] + , ReturnStat (SatInt 0) + , ReturnStat (SatInt 1) + ]))) + +func_with_locals_opt :: JStat +func_with_locals_opt = AssignStat (jvar (fsLit "foo")) + AssignOp + (ValExpr (JFunc [] + (BlockStat [ AssignStat (jvar (fsLit "one")) AssignOp (SatInt 2) + , AssignStat (jvar (fsLit "two")) AssignOp (SatInt 3) + , ApplStat (jvar (fsLit "f")) [(SatInt 100)] + , ReturnStat (SatInt 0) + ]))) + +-- This one comes straight from MR10260 where we noticed the optimizer was not catching the redundant return +bignum_test :: JStat +bignum_test = DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + , ReturnStat (ApplExpr (jvar $ fsLit "h$rs") [])])) + +bignum_test_opt :: JStat +bignum_test_opt = + DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + ])) + +bignum_test_2 :: JStat +bignum_test_2 = BlockStat [FuncStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99") [] (BlockStat [DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + , ReturnStat (ApplExpr (jvar $ fsLit "h$rs") [])]))])] + +bignum_test_opt_2 :: JStat +bignum_test_opt_2 = BlockStat [FuncStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99") [] (BlockStat [DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + ]))])] + +main :: IO () +main = mapM_ print + [ jsOptimize double_return == double_return_opt + , jsOptimize in_func == in_func_opt + , jsOptimize nested_blocks == nested_blocks_opt + , jsOptimize global_func == global_func_opt + , jsOptimize func_with_locals == func_with_locals_opt + , jsOptimize bignum_test == bignum_test_opt + , jsOptimize bignum_test_2 == bignum_test_opt_2 + ] ===================================== testsuite/tests/javascript/opt/deadCodeElim.stdout ===================================== @@ -0,0 +1,7 @@ +True +True +True +True +True +True +True ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -7,7 +7,7 @@ ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] ref compiler/GHC/Core/Opt/Specialise.hs:1790:28: Note [Arity decrease] ref compiler/GHC/Core/TyCo/Rep.hs:1556:31: Note [What prevents a constraint from floating] ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Driver/Session.hs:3993:49: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Session.hs:4062:49: Note [Eta-reduction in -O0] ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] ref compiler/GHC/Hs/Expr.hs:1736:87: Note [Lifecycle of a splice] ref compiler/GHC/Hs/Expr.hs:1772:7: Note [Pending Splices] @@ -15,6 +15,7 @@ ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constr ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/JS/Optimizer.hs:206:7: Note [Unsafe JavaScript optimizations] ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] ref compiler/GHC/StgToCmm.hs:106:18: Note [codegen-split-init] ref compiler/GHC/StgToCmm.hs:109:18: Note [pipeline-split-init] @@ -25,14 +26,14 @@ ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:357:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:532:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:656:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:889:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] ref compiler/GHC/Tc/Module.hs:711:15: Note [Extra dependencies from .hs-boot files] ref compiler/GHC/Tc/Solver/Rewrite.hs:1008:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1120:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/TyCl.hs:1124:6: Note [Unification variables need fresh Names] ref compiler/GHC/Tc/Types.hs:692:33: Note [Extra dependencies from .hs-boot files] ref compiler/GHC/Tc/Types.hs:1423:47: Note [Care with plugin imports] ref compiler/GHC/Tc/Types/Constraint.hs:255:34: Note [NonCanonical Semantics] @@ -46,8 +47,8 @@ ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threa ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ref linters/lint-notes/Notes.hs:69:22: Note [...] ref testsuite/config/ghc:272:10: Note [WayFlags] -ref testsuite/driver/testlib.py:160:10: Note [Why is there no stage1 setup function?] -ref testsuite/driver/testlib.py:164:2: Note [Why is there no stage1 setup function?] +ref testsuite/driver/testlib.py:165:10: Note [Why is there no stage1 setup function?] +ref testsuite/driver/testlib.py:169:2: Note [Why is there no stage1 setup function?] ref testsuite/mk/boilerplate.mk:267:2: Note [WayFlags] ref testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs:30:27: Note [Extra TcS Untouchables] ref testsuite/tests/perf/should_run/all.T:8:6: Note [Solving from instances when interacting Dicts] ===================================== testsuite/tests/th/T21050.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell, ImpredicativeTypes #-} +module T21050 where + +import Language.Haskell.TH.Syntax + +data T = MkT (forall a. a) + +f x = [|| MkT $$(x) ||] + +g :: Code Q (forall a. a) -> Code Q T +g x = [|| MkT $$(x) ||] ===================================== testsuite/tests/th/T21050.stderr ===================================== @@ -0,0 +1,26 @@ + +T21050.hs:8:18: error: [GHC-25897] + • Couldn't match expected type ‘Code m a1’ with actual type ‘p’ + ‘p’ is a rigid type variable bound by + the inferred type of f :: Quote m => p -> Code m T + at T21050.hs:8:1-23 + • In the expression: x + In the Template Haskell splice $$(x) + In the first argument of ‘MkT’, namely ‘$$(x)’ + • Relevant bindings include + x :: p (bound at T21050.hs:8:3) + f :: p -> Code m T (bound at T21050.hs:8:1) + +T21050.hs:11:18: error: [GHC-91028] + • Couldn't match type ‘a’ with ‘forall a2. a2’ + Expected: Code Q a + Actual: Code Q (forall a. a) + Cannot equate type variable ‘a’ + with a type involving polytypes: forall a2. a2 + ‘a’ is a rigid type variable bound by + a type expected by the context: + forall a. a + at T21050.hs:11:15-19 + • In the expression: x + In the Template Haskell splice $$(x) + In the first argument of ‘MkT’, namely ‘$$(x)’ ===================================== testsuite/tests/th/all.T ===================================== @@ -564,3 +564,4 @@ test('TH_typed2', normal, compile_and_run, ['']) test('TH_typed3', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_typed4', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_typed5', normal, compile_and_run, ['']) +test('T21050', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/24effc0241d63dffc8f0add3c2092a860187c231...f7c1e9eba9a5597bcee3914637dfe77cedd4dda8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/24effc0241d63dffc8f0add3c2092a860187c231...f7c1e9eba9a5597bcee3914637dfe77cedd4dda8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 15:28:29 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Tue, 09 May 2023 11:28:29 -0400 Subject: [Git][ghc/ghc][wip/romes/target-has-rts-linker] Move "target has RTS linker" out of settings Message-ID: <645a669d8d30f_38ffdab433d57411518f6@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/target-has-rts-linker at Glasgow Haskell Compiler / GHC Commits: e52cbc96 by Rodrigo Mesquita at 2023-05-09T16:28:18+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Note that previously we would consider `powerpc`s and `s390x`s other than `powerpc-ibm-aix*` and `s390x-ibm-linux` to have an RTS linker, but the RTS linker supports neither platform. Closes #23361 - - - - - 10 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/Platform.hs - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -4727,8 +4727,9 @@ compilerInfo dflags ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), - ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), + ("Have native code generator", showBool $ platformNcgSupported platform), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make at . ===================================== compiler/GHC/Platform.hs ===================================== @@ -29,6 +29,7 @@ module GHC.Platform , platformInIntRange , platformInWordRange , platformCConvNeedsExtension + , platformHasRTSLinker , PlatformMisc(..) , SseVersion (..) , BmiVersion (..) @@ -271,6 +272,23 @@ platformCConvNeedsExtension platform = case platformArch platform of | OSDarwin <- platformOS platform -> True _ -> False +-- | Does this platform have an RTS linker? +platformHasRTSLinker :: Platform -> Bool +-- Note that we've inlined this logic in hadrian's +-- Settings.Builders.RunTest.inTreeCompilerArgs. +-- If you change this, be sure to change it too +platformHasRTSLinker p = case archOS_arch (platformArchOS p) of + ArchPPC -> False -- powerpc + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False + ArchRISCV64 -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + ArchWasm32 -> False + _ -> True + + -------------------------------------------------- -- Instruction sets ===================================== configure.ac ===================================== @@ -330,18 +330,6 @@ if test x"$TablesNextToCode" = xYES; then fi AC_SUBST(TablesNextToCode) -dnl ** Does target have runtime linker support? -dnl -------------------------------------------------------------- -case "$target" in - powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|javascript-*|loongarch64-*) - TargetHasRTSLinker=NO - ;; - *) - TargetHasRTSLinker=YES - ;; -esac -AC_SUBST(TargetHasRTSLinker) - # Requires FPTOOLS_SET_PLATFORMS_VARS to be run first. FP_FIND_ROOT ===================================== distrib/configure.ac.in ===================================== @@ -20,9 +20,6 @@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ -TargetHasRTSLinker=@TargetHasRTSLinker@ -AC_SUBST(TargetHasRTSLinker) - TargetHasLibm=@TargetHasLibm@ AC_SUBST(TargetHasLibm) ===================================== hadrian/bindist/Makefile ===================================== @@ -116,7 +116,6 @@ lib/settings : config.mk @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ - @echo ',("target has RTS linker", "$(TargetHasRTSLinker)")' >> $@ @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ @echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -253,7 +253,6 @@ TargetWordBigEndian = @TargetWordBigEndian@ TargetHasGnuNonexecStack = @TargetHasGnuNonexecStack@ TargetHasIdentDirective = @TargetHasIdentDirective@ TargetHasSubsectionsViaSymbols = @TargetHasSubsectionsViaSymbols@ -TargetHasRTSLinker = @TargetHasRTSLinker@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -173,7 +173,6 @@ target-word-big-endian = @TargetWordBigEndian@ target-has-gnu-nonexec-stack = @TargetHasGnuNonexecStack@ target-has-ident-directive = @TargetHasIdentDirective@ target-has-subsections-via-symbols = @TargetHasSubsectionsViaSymbols@ -target-has-rts-linker = @TargetHasRTSLinker@ target-has-libm = @TargetHasLibm@ target-arm-version = @ARM_ISA@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -79,7 +79,6 @@ data Setting = BuildArch | TargetOsHaskell | TargetArmVersion | TargetWordSize - | TargetHasRtsLinker | BourneShell -- TODO: Reduce the variety of similar flags (e.g. CPP and non-CPP versions). @@ -181,7 +180,6 @@ setting key = lookupSystemConfig $ case key of TargetArchHaskell -> "target-arch-haskell" TargetOsHaskell -> "target-os-haskell" TargetWordSize -> "target-word-size" - TargetHasRtsLinker -> "target-has-rts-linker" BourneShell -> "bourne-shell" bootIsStage0 :: Stage -> Stage ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -451,7 +451,6 @@ generateSettings = do , ("target has GNU nonexec stack", expr $ lookupSystemConfig "target-has-gnu-nonexec-stack") , ("target has .ident directive", expr $ lookupSystemConfig "target-has-ident-directive") , ("target has subsections via symbols", expr $ lookupSystemConfig "target-has-subsections-via-symbols") - , ("target has RTS linker", expr $ lookupSystemConfig "target-has-rts-linker") , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) , ("LLVM target", getSetting LlvmTarget) ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -126,7 +126,10 @@ inTreeCompilerArgs stg = do libdir <- System.FilePath.normalise . (top -/-) <$> stageLibPath stg - rtsLinker <- (== "YES") <$> setting TargetHasRtsLinker + -- For this information, we need to query ghc --info, however, that would + -- require building ghc, which we don't want to do here. Therefore, the + -- logic from `platformHasRTSLinker` is duplicated here. + let rtsLinker = arch `elem` ["powerpc", "powerpc64", "powerpc64le", "s390x", "riscv64", "loongarch64", "javascript", "wasm32"] return TestCompilerArgs{..} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e52cbc969703bd0bfdbb0cb1bb8c8a198e9f005b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e52cbc969703bd0bfdbb0cb1bb8c8a198e9f005b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 15:35:25 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Tue, 09 May 2023 11:35:25 -0400 Subject: [Git][ghc/ghc][wip/toolchain-selection] 194 commits: Allow WARNING pragmas to be controlled with custom categories Message-ID: <645a683dbdaf4_38ffdab58860e811631b2@gitlab.mail> Rodrigo Mesquita pushed to branch wip/toolchain-selection at Glasgow Haskell Compiler / GHC Commits: f932c589 by Adam Gundry at 2023-03-24T02:36:09-04:00 Allow WARNING pragmas to be controlled with custom categories Closes #17209. This implements GHC Proposal 541, allowing a WARNING pragma to be annotated with a category like so: {-# WARNING in "x-partial" head "This function is undefined on empty lists." #-} The user can then enable, disable and set the severity of such warnings using command-line flags `-Wx-partial`, `-Werror=x-partial` and so on. There is a new warning group `-Wextended-warnings` containing all these warnings. Warnings without a category are treated as if the category was `deprecations`, and are (still) controlled by the flags `-Wdeprecations` and `-Wwarnings-deprecations`. Updates Haddock submodule. - - - - - 0426515b by Adam Gundry at 2023-03-24T02:36:09-04:00 Move mention of warning groups change to 9.8.1 release notes - - - - - b8d783d2 by Ben Gamari at 2023-03-24T02:36:45-04:00 nativeGen/AArch64: Fix bitmask immediate predicate Previously the predicate for determining whether a logical instruction operand could be encoded as a bitmask immediate was far too conservative. This meant that, e.g., pointer untagged required five instructions whereas it should only require one. Fixes #23030. - - - - - 46120bb6 by Joachim Breitner at 2023-03-24T13:09:43-04:00 User's guide: Improve docs for -Wall previously it would list the warnings _not_ enabled by -Wall. That’s unnecessary round-about and was out of date. So let's just name the relevant warnings (based on `compiler/GHC/Driver/Flags.hs`). - - - - - 509d1f11 by Ben Gamari at 2023-03-24T13:10:20-04:00 codeGen/tsan: Disable instrumentation of unaligned stores There is some disagreement regarding the prototype of `__tsan_unaligned_write` (specifically whether it takes just the written address, or the address and the value as an argument). Moreover, I have observed crashes which appear to be due to it. Disable instrumentation of unaligned stores as a temporary mitigation. Fixes #23096. - - - - - 6a73655f by Li-yao Xia at 2023-03-25T00:02:44-04:00 base: Document GHC versions associated with past base versions in the changelog - - - - - 43bd7694 by Teo Camarasu at 2023-03-25T00:03:24-04:00 Add regression test for #17574 This test currently fails in the nonmoving way - - - - - f2d56bf7 by Teo Camarasu at 2023-03-25T00:03:24-04:00 fix: account for large and compact object stats with nonmoving gc Make sure that we keep track of the size of large and compact objects that have been moved onto the nonmoving heap. We keep track of their size and add it to the amount of live bytes in nonmoving segments to get the total size of the live nonmoving heap. Resolves #17574 - - - - - 7131b705 by David Feuer at 2023-03-25T00:04:04-04:00 Modify ThreadId documentation and comments For a long time, `GHC.Conc.Sync` has said ```haskell -- ToDo: data ThreadId = ThreadId (Weak ThreadId#) -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. ``` We are now actually capable of using `Weak# ThreadId#`, but the world has moved on. To support the `Show` and `Ord` instances, we'd need to store the thread ID number in the `ThreadId`. And it seems very difficult to continue to support `threadStatus` in that regime, since it needs to be able to explain how threads died. In addition, garbage collection of weak references can be quite expensive, and it would be hard to evaluate the cost over he whole ecosystem. As discussed in [this CLC issue](https://github.com/haskell/core-libraries-committee/issues/125), it doesn't seem very likely that we'll actually switch to weak references here. - - - - - c421bbbb by Ben Gamari at 2023-03-25T00:04:41-04:00 rts: Fix barriers of IND and IND_STATIC Previously IND and IND_STATIC lacked the acquire barriers enjoyed by BLACKHOLE. As noted in the (now updated) Note [Heap memory barriers], this barrier is critical to ensure that the indirectee is visible to the entering core. Fixes #22872. - - - - - 62fa7faa by Bodigrim at 2023-03-25T00:05:22-04:00 Improve documentation of atomicModifyMutVar2# - - - - - b2d14d0b by Cheng Shao at 2023-03-25T03:46:43-04:00 rts: use performBlockingMajorGC in hs_perform_gc and fix ffi023 This patch does a few things: - Add the missing RtsSymbols.c entry of performBlockingMajorGC - Make hs_perform_gc call performBlockingMajorGC, which restores previous behavior - Use hs_perform_gc in ffi023 - Remove rts_clearMemory() call in ffi023, it now works again in some test ways previously marked as broken. Fixes #23089 - - - - - d9ae24ad by Cheng Shao at 2023-03-25T03:46:44-04:00 testsuite: add the rts_clearMemory test case This patch adds a standalone test case for rts_clearMemory that mimics how it's typically used by wasm backend users and ensures this RTS API isn't broken by future RTS refactorings. Fixes #23901. - - - - - 80729d96 by Bodigrim at 2023-03-25T03:47:22-04:00 Improve documentation for resizing of byte arrays - - - - - c6ec4cd1 by Ben Gamari at 2023-03-25T20:23:47-04:00 rts: Don't rely on EXTERN_INLINE for slop-zeroing logic Previously we relied on calling EXTERN_INLINE functions defined in ClosureMacros.h from Cmm to zero slop. However, as far as I can tell, this is no longer safe to do in C99 as EXTERN_INLINE definitions may be emitted in each compilation unit. Fix this by explicitly declaring a new set of non-inline functions in ZeroSlop.c which can be called from Cmm and marking the ClosureMacros.h definitions as INLINE_HEADER. In the future we should try to eliminate EXTERN_INLINE. - - - - - c32abd4b by Ben Gamari at 2023-03-25T20:23:48-04:00 rts: Fix capability-count check in zeroSlop Previously `zeroSlop` examined `RtsFlags` to determine whether the program was single-threaded. This is wrong; a program may be started with `+RTS -N1` yet the process may later increase the capability count with `setNumCapabilities`. This lead to quite subtle and rare crashes. Fixes #23088. - - - - - 656d4cb3 by Ryan Scott at 2023-03-25T20:24:23-04:00 Add Eq/Ord instances for SSymbol, SChar, and SNat This implements [CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148). - - - - - 4f93de88 by David Feuer at 2023-03-26T15:33:02-04:00 Update and expand atomic modification Haddocks * The documentation for `atomicModifyIORef` and `atomicModifyIORef'` were incomplete, and the documentation for `atomicModifyIORef` was out of date. Update and expand. * Remove a useless lazy pattern match in the definition of `atomicModifyIORef`. The pair it claims to match lazily was already forced by `atomicModifyIORef2`. - - - - - e1fb56b2 by David Feuer at 2023-03-26T15:33:41-04:00 Document the constructor name for lists Derived `Data` instances use raw infix constructor names when applicable. The `Data.Data [a]` instance, if derived, would have a constructor name of `":"`. However, it actually uses constructor name `"(:)"`. Document this peculiarity. See https://github.com/haskell/core-libraries-committee/issues/147 - - - - - c1f755c4 by Simon Peyton Jones at 2023-03-27T22:09:41+01:00 Make exprIsConApp_maybe a bit cleverer Addresses #23159. See Note Note [Exploit occ-info in exprIsConApp_maybe] in GHC.Core.SimpleOpt. Compile times go down very slightly, but always go down, never up. Good! Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -1.8% T15703(normal) -1.2% GOOD geo. mean -0.1% minimum -1.8% maximum +0.0% Metric Decrease: CoOpt_Singletons T15703 - - - - - 76bb4c58 by Ryan Scott at 2023-03-28T08:12:08-04:00 Add COMPLETE pragmas to TypeRep, SSymbol, SChar, and SNat This implements [CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149). - - - - - 3f374399 by sheaf at 2023-03-29T13:57:33+02:00 Handle records in the renamer This patch moves the field-based logic for disambiguating record updates to the renamer. The type-directed logic, scheduled for removal, remains in the typechecker. To do this properly (and fix the myriad of bugs surrounding the treatment of duplicate record fields), we took the following main steps: 1. Create GREInfo, a renamer-level equivalent to TyThing which stores information pertinent to the renamer. This allows us to uniformly treat imported and local Names in the renamer, as described in Note [GREInfo]. 2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which distinguished between normal names and field names, we now store simple Names in GlobalRdrElt, along with the new GREInfo information which allows us to recover the FieldLabel for record fields. 3. Add namespacing for record fields, within the OccNames themselves. This allows us to remove the mangling of duplicate field selectors. This change ensures we don't print mangled names to the user in error messages, and allows us to handle duplicate record fields in Template Haskell. 4. Move record disambiguation to the renamer, and operate on the level of data constructors instead, to handle #21443. The error message text for ambiguous record updates has also been changed to reflect that type-directed disambiguation is on the way out. (3) means that OccEnv is now a bit more complex: we first key on the textual name, which gives an inner map keyed on NameSpace: OccEnv a ~ FastStringEnv (UniqFM NameSpace a) Note that this change, along with (2), both increase the memory residency of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to regress somewhat in compile-time allocation. Even though (3) simplified a lot of code (in particular the treatment of field selectors within Template Haskell and in error messages), it came with one important wrinkle: in the situation of -- M.hs-boot module M where { data A; foo :: A -> Int } -- M.hs module M where { data A = MkA { foo :: Int } } we have that M.hs-boot exports a variable foo, which is supposed to match with the record field foo that M exports. To solve this issue, we add a new impedance-matching binding to M foo{var} = foo{fld} This mimics the logic that existed already for impedance-binding DFunIds, but getting it right was a bit tricky. See Note [Record field impedance matching] in GHC.Tc.Module. We also needed to be careful to avoid introducing space leaks in GHCi. So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in ModIface. This means stubbing out all the GREInfo fields, with the function forceGlobalRdrEnv. When we read it back in, we rehydrate with rehydrateGlobalRdrEnv. This robustly avoids any space leaks caused by retaining old type environments. Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063 Updates haddock submodule ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiLayerModulesDefsGhci MultiLayerModulesNoCode T13701 T14697 hard_hole_fits ------------------------- - - - - - 4f1940f0 by sheaf at 2023-03-29T13:57:33+02:00 Avoid repeatedly shadowing in shadowNames This commit refactors GHC.Type.Name.Reader.shadowNames to first accumulate all the shadowing arising from the introduction of a new set of GREs, and then applies all the shadowing to the old GlobalRdrEnv in one go. - - - - - d246049c by sheaf at 2023-03-29T13:57:34+02:00 igre_prompt_env: discard "only-qualified" names We were unnecessarily carrying around names only available qualified in igre_prompt_env, violating the icReaderEnv invariant. We now get rid of these, as they aren't needed for the shadowing computation that igre_prompt_env exists for. Fixes #23177 ------------------------- Metric Decrease: T14052 T14052Type ------------------------- - - - - - 41a572f6 by Matthew Pickering at 2023-03-29T16:17:21-04:00 hadrian: Fix path to HpcParser.y The source for this project has been moved into a src/ folder so we also need to update this path. Fixes #23187 - - - - - b159e0e9 by doyougnu at 2023-03-30T01:40:08-04:00 js: split JMacro into JS eDSL and JS syntax This commit: Splits JExpr and JStat into two nearly identical DSLs: - GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a value cannot be unsaturated, or, a value of this DSL is a witness that a value of GHC.JS.Unsat has been saturated - GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation. Then all binary and outputable instances are changed to use GHC.JS.Syntax. This moves us closer to closing out #22736 and #22352. See #22736 for roadmap. ------------------------- Metric Increase: CoOpt_Read LargeRecord ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T10858 T11195 T11374 T11822 T12227 T12707 T13035 T13253 T13253-spj T13379 T14683 T15164 T15703 T16577 T17096 T17516 T17836 T18140 T18282 T18304 T18478 T18698a T18698b T18923 T1969 T19695 T20049 T21839c T3064 T4801 T5321FD T5321Fun T5631 T5642 T783 T9198 T9233 T9630 TcPlugin_RewritePerf WWRec ------------------------- - - - - - f4f1f14f by Sylvain Henry at 2023-03-30T01:40:49-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. Also used the opportunity to reenable 64-bit Word/Int tests - - - - - a5360490 by Ben Gamari at 2023-03-30T01:41:25-04:00 testsuite: Fix racing prints in T21465 As noted in #23155, we previously failed to add flushes necessary to ensure predictable output. Fixes #23155. - - - - - 98b5cf67 by Matthew Pickering at 2023-03-30T09:58:40+01:00 Revert "ghc-heap: remove wrong Addr# coercion (#23181)" This reverts commit f4f1f14f8009c3c120b8b963ec130cbbc774ec02. This fails to build with GHC-9.2 as a boot compiler. See #23195 for tracking this issue. - - - - - 61a2dfaa by Bodigrim at 2023-03-30T14:35:57-04:00 Add {-# WARNING #-} to Data.List.{head,tail} - - - - - 8f15c47c by Bodigrim at 2023-03-30T14:35:57-04:00 Fixes to accomodate Data.List.{head,tail} with {-# WARNING #-} - - - - - 7c7dbade by Bodigrim at 2023-03-30T14:35:57-04:00 Bump submodules - - - - - d2d8251b by Bodigrim at 2023-03-30T14:35:57-04:00 Fix tests - - - - - 3d38dcb6 by sheaf at 2023-03-30T14:35:57-04:00 Proxies for head and tail: review suggestions - - - - - 930edcfd by sheaf at 2023-03-30T14:36:33-04:00 docs: move RecordUpd changelog entry to 9.8 This was accidentally included in the 9.6 changelog instead of the 9.6 changelog. - - - - - 6f885e65 by sheaf at 2023-03-30T14:37:09-04:00 Add LANGUAGE GADTs to GHC.Rename.Env We need to enable this extension for the file to compile with ghc 9.2, as we are pattern matching on a GADT and this required the GADT extension to be enabled until 9.4. - - - - - 6d6a37a8 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: make lint-ci-config job fast again We don't pin our nixpkgs revision and tracks the default nixpkgs-unstable channel anyway. Instead of using haskell.packages.ghc924, we should be using haskell.packages.ghc92 to maximize the binary cache hit rate and make lint-ci-config job fast again. Also bumps the nix docker image to the latest revision. - - - - - ef1548c4 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: ensure that all non-i386 pipelines do parallel xz compression We can safely enable parallel xz compression for non-i386 pipelines. However, previously we didn't export XZ_OPT, so the xz process won't see it if XZ_OPT hasn't already been set in the current job. - - - - - 20432d16 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: unset CROSS_EMULATOR for js job - - - - - 4a24dbbe by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: fix lint-testsuite job The list_broken make target will transitively depend on the calibrate.out target, which used STAGE1_GHC instead of TEST_HC. It really should be TEST_HC since that's what get passed in the gitlab CI config. - - - - - cea56ccc by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: use alpine3_17-wasm image for wasm jobs Bump the ci-images dependency and use the new alpine3_17-wasm docker image for wasm jobs. - - - - - 79d0cb32 by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - e7392b4e by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Normalize away differences in ghc executable name - - - - - ee160d06 by Ben Gamari at 2023-03-30T18:43:53+00:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - 30c84511 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: don't add optllvm way for wasm32 - - - - - f1beee36 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: normalize the .wasm extension - - - - - a984a103 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: strip the cross ghc prefix in output and error message - - - - - f7478d95 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: handle target executable extension - - - - - 8fe8b653 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: mypy typing error fixes This patch fixes some mypy typing errors which weren't caught in previous linting jobs. - - - - - 0149f32f by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: use context variable instead of thread-local variable This patch changes a thread-local variable to context variable instead, which works as intended when the testsuite transitions to use asyncio & coroutines instead of multi-threading to concurrently run test cases. Note that this also raises the minimum Python version to 3.7. - - - - - ea853ff0 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: asyncify the testsuite driver This patch refactors the testsuite driver, gets rid of multi-threading logic for running test cases concurrently, and uses asyncio & coroutines instead. This is not yak shaving for its own sake; the previous multi-threading logic is prone to livelock/deadlock conditions for some reason, even if the total number of threads is bounded to a thread pool's capacity. The asyncify change is an internal implementation detail of the testsuite driver and does not impact most GHC maintainers out there. The patch does not touch the .T files, test cases can be added/modified the exact same way as before. - - - - - 0077cb22 by Matthew Pickering at 2023-03-31T21:28:28-04:00 Add test for T23184 There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj at microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 A bunch of changes related to eta reduction This is a large collection of changes all relating to eta reduction, originally triggered by #18993, but there followed a long saga. Specifics: ...lots of lines omitted... Other incidental changes * Fix a fairly long-standing outright bug in the ApplyToVal case of GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the tail of 'dmds' in the recursive call, which meant the demands were All Wrong. I have no idea why this has not caused problems before now. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes. - - - - - 62d25071 by mangoiv at 2023-04-01T04:20:01-04:00 [feat] make ($) representation polymorphic - this change was approved by the CLC in [1] following a CLC proposal [2] - make ($) representation polymorphic (adjust the type signature) - change ($) implementation to allow additional polymorphism - adjust the haddock of ($) to reflect these changes - add additional documentation to document these changes - add changelog entry - adjust tests (move now succeeding tests and adjust stdout of some tests) [1] https://github.com/haskell/core-libraries-committee/issues/132#issuecomment-1487456854 [2] https://github.com/haskell/core-libraries-committee/issues/132 - - - - - 77c33fb9 by Artem Pelenitsyn at 2023-04-01T04:20:41-04:00 User Guide: update copyright year: 2020->2023 - - - - - 3b5be05a by doyougnu at 2023-04-01T09:42:31-04:00 driver: Unit State Data.Map -> GHC.Unique.UniqMap In pursuit of #22426. The driver and unit state are major contributors. This commit also bumps the haddock submodule to reflect the API changes in UniqMap. ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp T10421 T10547 T12150 T12234 T12425 T13035 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T5837 T6048 T9198 ------------------------- - - - - - a84fba6e by Torsten Schmits at 2023-04-01T09:43:12-04:00 Add structured error messages for GHC.Tc.TyCl Tracking ticket: #20117 MR: !10183 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 6e2eb275 by doyougnu at 2023-04-01T18:27:56-04:00 JS: Linker: use saturated JExpr Follow on to MR!10142 in pursuit of #22736 - - - - - 3da69346 by sheaf at 2023-04-01T18:28:37-04:00 Improve haddocks of template-haskell Con datatype This adds a bit more information, in particular about the lists of constructors in the GadtC and RecGadtC cases. - - - - - 3b7bbb39 by sheaf at 2023-04-01T18:28:37-04:00 TH: revert changes to GadtC & RecGadtC Commit 3f374399 included a breaking-change to the template-haskell library when it made the GadtC and RecGadtC constructors take non-empty lists of names. As this has the potential to break many users' packages, we decided to revert these changes for now. - - - - - f60f6110 by Bodigrim at 2023-04-02T18:59:30-04:00 Rework documentation for data Char - - - - - 43ebd5dc by Bodigrim at 2023-04-02T19:00:09-04:00 cmm: implement parsing of MO_AtomicRMW from hand-written CMM files Fixes #23206 - - - - - ab9cd52d by Sylvain Henry at 2023-04-03T08:15:21-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. - - - - - 2b2afff3 by Matthew Pickering at 2023-04-03T08:15:58-04:00 hadrian: Update bootstrap plans for 9.2.6, 9.2.7, 9.4.4, 9.4.5, 9.6.1 Also fixes the ./generate_bootstrap_plans script which was recently broken We can hopefully drop the 9.2 plans soon but they still work so kept them around for now. - - - - - c2605e25 by Matthew Pickering at 2023-04-03T08:15:58-04:00 ci: Add job to test 9.6 bootstrapping - - - - - 53e4d513 by Krzysztof Gogolewski at 2023-04-03T08:16:35-04:00 hadrian: Improve option parsing Several options in Hadrian had their argument marked as optional (`OptArg`), but if the argument wasn't there they were just giving an error. It's more idiomatic to mark the argument as required instead; the code uses less Maybes, the parser can enforce that the argument is present, --help gives better output. - - - - - a8e36892 by Sylvain Henry at 2023-04-03T08:17:16-04:00 JS: fix issues with FD api support - Add missing implementations for fcntl_read/write/lock - Fix fdGetMode These were found while implementing TH in !9779. These functions must be used somehow by the external interpreter code. - - - - - 8b092910 by Haskell-mouse at 2023-04-03T19:31:26-04:00 Convert diagnostics in GHC.Rename.HsType to proper TcRnMessage I've turned all occurrences of TcRnUnknownMessage in GHC.Rename.HsType module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnDataKindsError TcRnUnusedQuantifiedTypeVar TcRnIllegalKindSignature TcRnUnexpectedPatSigType TcRnSectionPrecedenceError TcRnPrecedenceParsingError TcRnIllegalKind TcRnNegativeNumTypeLiteral TcRnUnexpectedKindVar TcRnBindMultipleVariables TcRnBindVarAlreadyInScope - - - - - 220a7a48 by Krzysztof Gogolewski at 2023-04-03T19:32:02-04:00 Fixes around unsafeCoerce# 1. `unsafeCoerce#` was documented in `GHC.Prim`. But since the overhaul in 74ad75e87317, `unsafeCoerce#` is no longer defined there. I've combined the documentation in `GHC.Prim` with the `Unsafe.Coerce` module. 2. The documentation of `unsafeCoerce#` stated that you should not cast a function to an algebraic type, even if you later cast it back before applying it. But ghci was doing that type of cast, as can be seen with 'ghci -ddump-ds' and typing 'x = not'. I've changed it to use Any following the documentation. - - - - - 9095e297 by Matthew Craven at 2023-04-04T01:04:10-04:00 Add a few more memcpy-ish primops * copyMutableByteArrayNonOverlapping# * copyAddrToAddr# * copyAddrToAddrNonOverlapping# * setAddrRange# The implementations of copyBytes, moveBytes, and fillBytes in base:Foreign.Marshal.Utils now use these new primops, which can cause us to work a bit harder generating code for them, resulting in the metric increase in T21839c observed by CI on some architectures. But in exchange, we get better code! Metric Increase: T21839c - - - - - f7da530c by Matthew Craven at 2023-04-04T01:04:10-04:00 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. - - - - - cd00e321 by sheaf at 2023-04-04T01:04:50-04:00 Relax assertion in varToRecFieldOcc When using Template Haskell, it is possible to re-parent a field OccName belonging to one data constructor to another data constructor. The lsp-types package did this in order to "extend" a data constructor with additional fields. This ran into an assertion in 'varToRecFieldOcc'. This assertion can simply be relaxed, as the resulting splices are perfectly sound. Fixes #23220 - - - - - eed0d930 by Sylvain Henry at 2023-04-04T11:09:15-04:00 GHCi.RemoteTypes: fix doc and avoid unsafeCoerce (#23201) - - - - - 071139c3 by Ryan Scott at 2023-04-04T11:09:51-04:00 Make INLINE pragmas for pattern synonyms work with TH Previously, the code for converting `INLINE <name>` pragmas from TH splices used `vNameN`, which assumed that `<name>` must live in the variable namespace. Pattern synonyms, on the other hand, live in the constructor namespace. I've fixed the issue by switching to `vcNameN` instead, which works for both the variable and constructor namespaces. Fixes #23203. - - - - - 7c16f3be by Krzysztof Gogolewski at 2023-04-04T17:13:00-04:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). - - - - - c165f079 by sheaf at 2023-04-04T17:13:40-04:00 Add testcase for #23192 This issue around solving of constraints arising from superclass expansion using other constraints also borned from superclass expansion was the topic of commit aed1974e. That commit made sure we don't emit a "redundant constraint" warning in a situation in which removing the constraint would cause errors. Fixes #23192 - - - - - d1bb16ed by Ben Gamari at 2023-04-06T03:40:45-04:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 - - - - - 04b80850 by Brandon Chinn at 2023-04-06T03:41:21-04:00 Fix reverse flag for -Wunsupported-llvm-version - - - - - 0c990e13 by Pierre Le Marre at 2023-04-06T10:16:29+00:00 Add release note for GHC.Unicode refactor in base-4.18. Also merge CLC proposal 130 in base-4.19 with CLC proposal 59 in base-4.18 and add proper release date. - - - - - cbbfb283 by Alex Dixon at 2023-04-07T18:27:45-04:00 Improve documentation for ($) (#22963) - - - - - 5193c2b0 by Alex Dixon at 2023-04-07T18:27:45-04:00 Remove trailing whitespace from ($) commentary - - - - - b384523b by Sebastian Graf at 2023-04-07T18:27:45-04:00 Adjust wording wrt representation polymorphism of ($) - - - - - 6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00 Add structured error messages for GHC.Tc.TyCl.Utils Tracking ticket: #20117 MR: !10251 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00 Renamer: don't call addUsedGRE on an exact Name When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc, we could end up calling addUsedGRE on an exact Name, which would then lead to a panic in the bestImport function: it would be incapable of processing a GRE which is not local but also not brought into scope by any imports (as it is referred to by its unique instead). Fixes #23240 - - - - - bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00 Set base 'maintainer' field to CLC - - - - - ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00 Clarify a couple of Notes about 'nospec' - - - - - ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - a3c6d8f1 by Rodrigo Mesquita at 2023-05-09T16:34:35+01:00 Move "target has RTS linker" out of settings We move the "target has RTS linker" information out of configure into a predicate in GHC, and remove this option from the settings file where it is unnecessary -- it's information statically known from the platform. Closes #23361 - - - - - 2ab7ae0a by Ben Gamari at 2023-05-09T16:34:35+01:00 ghc-toolchain: Initial commit - - - - - 03dd35df by Ben Gamari at 2023-05-09T16:34:35+01:00 configure: Rip out Solaris dyld check Solaris 11 was released over a decade ago and, moreover, I doubt we have any Solaris users - - - - - a633f420 by Ben Gamari at 2023-05-09T16:34:35+01:00 Move via-C flags into GHC - - - - - 76e5ed1e by Ben Gamari at 2023-05-09T16:34:35+01:00 Rip out runtime linker/compiler checks - - - - - 94ef73bd by Ben Gamari at 2023-05-09T16:34:35+01:00 configure: Rip out toolchain selection logic - - - - - 27695105 by Ben Gamari at 2023-05-09T16:34:36+01:00 Fixes - - - - - 7dfa1f4e by Rodrigo Mesquita at 2023-05-09T16:34:36+01:00 ghc-toolchain: Rename readProcess to readProcessStdout Fixes bugs regarding a translation from the original autconf program that failed to account for the exit code. The longer name reenforces that we really only care about the stdout, and the exit code and stderr of the program are irrelevant for the case. - - - - - 06c048f3 by Rodrigo Mesquita at 2023-05-09T16:34:36+01:00 Re-introduce ld-override option - - - - - 80de30b4 by Rodrigo Mesquita at 2023-05-09T16:34:36+01:00 ROMES:WIP - - - - - b8044245 by Rodrigo Mesquita at 2023-05-09T16:35:07+01:00 ghc-toolchain library and usage in hadrian flags - - - - - 449c8888 by Rodrigo Mesquita at 2023-05-09T16:35:08+01:00 ROMES: WIP - - - - - 7332d2b9 by Rodrigo Mesquita at 2023-05-09T16:35:08+01:00 Re-introduce flags in hadrian config - - - - - 331d4ec7 by Rodrigo Mesquita at 2023-05-09T16:35:09+01:00 ROMES WIP - - - - - 48620a41 by Rodrigo Mesquita at 2023-05-09T16:35:09+01:00 ghc-toolchain: UseLibFFI, LdCompactUnwind, LdFileList A more complete ghc-toolchain. Added configuration of: * Use libffi for adjustors * Supports compact unwind * Supports filelist - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/generate_job_metadata - .gitlab/generate_jobs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - .gitmodules - cabal.project-reinstall - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/Wasm/Types.hs - compiler/GHC/CmmToAsm/Wasm/Utils.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d1387b26399d0fa2dce2e6948afbab3ba80dfb0a...48620a416e8764beeb69d1fa5f975f6fbf6f0a06 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d1387b26399d0fa2dce2e6948afbab3ba80dfb0a...48620a416e8764beeb69d1fa5f975f6fbf6f0a06 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 16:22:03 2023 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Tue, 09 May 2023 12:22:03 -0400 Subject: [Git][ghc/ghc][wip/T23025] 67 commits: hadrian: Pass haddock file arguments in a response file Message-ID: <645a732bf011c_38ffdab899e1f81184217@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T23025 at Glasgow Haskell Compiler / GHC Commits: f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 3e3a6be4 by Ben Gamari at 2023-05-08T12:15:19+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 78c8dc50 by Torsten Schmits at 2023-05-08T21:41:51-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 0e2df4c9 by Bryan Richter at 2023-05-09T12:03:35+03:00 Fix up rules for ghcup-metadata-nightly-push - - - - - 0251e6c4 by Krzysztof Gogolewski at 2023-05-09T18:20:16+02:00 WIP on #23025 - - - - - c6f701a5 by Krzysztof Gogolewski at 2023-05-09T18:20:16+02:00 WIP: fix another bug - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/UsageEnv.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - + compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Syn/Type.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e9a5a9b4e27df4d13f4cb44a389f7afef885c5d5...c6f701a57cb22def21ca219e5eee50d4746b4822 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e9a5a9b4e27df4d13f4cb44a389f7afef885c5d5...c6f701a57cb22def21ca219e5eee50d4746b4822 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 17:47:42 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 13:47:42 -0400 Subject: [Git][ghc/ghc][wip/orig-thunk-info] 3 commits: Fix up rules for ghcup-metadata-nightly-push Message-ID: <645a873e185a9_38ffdabc97b3981213130@gitlab.mail> Ben Gamari pushed to branch wip/orig-thunk-info at Glasgow Haskell Compiler / GHC Commits: 0e2df4c9 by Bryan Richter at 2023-05-09T12:03:35+03:00 Fix up rules for ghcup-metadata-nightly-push - - - - - 4e59bbf9 by Ben Gamari at 2023-05-09T13:47:34-04:00 compiler: Fingerprint more code generation flags Previously our recompilation check was quite inconsistent in its coverage of non-optimisation code generation flags. Specifically, we failed to account for most flags that would affect the behavior of generated code in ways that might affect the result of a program's execution (e.g. `-feager-blackholing`, `-fstrict-dicts`) - - - - - 3d32cad7 by Ben Gamari at 2023-05-09T13:47:34-04:00 compiler: Record original thunk info tables on stack - - - - - 13 changed files: - .gitlab-ci.yml - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Recomp/Flags.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - docs/users_guide/debugging.rst - rts/StgMiscClosures.cmm - rts/include/rts/storage/Closures.h - testsuite/tests/driver/T13914/T13914.stdout - utils/deriveConstants/Main.hs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1048,7 +1048,7 @@ ghcup-metadata-nightly: rules: - if: $NIGHTLY -# Update the +# Update the ghcup metadata with information about this nightly pipeline ghcup-metadata-nightly-push: stage: deploy image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV" @@ -1072,11 +1072,8 @@ ghcup-metadata-nightly-push: - git commit -m "Update metadata" - git push gitlab_origin HEAD:updates -o ci.skip rules: - - if: $NIGHTLY # Only run the update on scheduled nightly pipelines, ie once a day - - if: $CI_PIPELINE_SOURCE == "schedule" - # And only update the metadata for master branch - - if: '$CI_COMMIT_BRANCH == "master"' + - if: $NIGHTLY && $CI_PIPELINE_SOURCE == "schedule" && $CI_COMMIT_BRANCH == "master" ghcup-metadata-release: ===================================== compiler/GHC/Cmm/CLabel.hs ===================================== @@ -53,6 +53,7 @@ module GHC.Cmm.CLabel ( mkDirty_MUT_VAR_Label, mkMUT_VAR_CLEAN_infoLabel, mkNonmovingWriteBarrierEnabledLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, @@ -641,7 +642,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable -- Constructing Cmm Labels mkDirty_MUT_VAR_Label, mkNonmovingWriteBarrierEnabledLabel, - mkUpdInfoLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, mkMAP_DIRTY_infoLabel, @@ -655,6 +656,7 @@ mkDirty_MUT_VAR_Label, mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData +mkOrigThunkInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo ===================================== compiler/GHC/Driver/Config/StgToCmm.hs ===================================== @@ -37,6 +37,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig , stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags , stgToCmmSCCProfiling = sccProfilingEnabled dflags , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags + , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo dflags , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags , stgToCmmOmitYields = gopt Opt_OmitYields dflags , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -5,6 +5,7 @@ module GHC.Driver.Flags , GeneralFlag(..) , Language(..) , optimisationFlags + , codeGenFlags -- * Warnings , WarningGroup(..) @@ -328,6 +329,7 @@ data GeneralFlag | Opt_IgnoreHpcChanges | Opt_ExcessPrecision | Opt_EagerBlackHoling + | Opt_OrigThunkInfo | Opt_NoHsMain | Opt_SplitSections | Opt_StgStats @@ -473,15 +475,11 @@ data GeneralFlag | Opt_G_NoOptCoercion deriving (Eq, Show, Enum) --- Check whether a flag should be considered an "optimisation flag" --- for purposes of recompilation avoidance (see --- Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags). Being listed here is --- not a guarantee that the flag has no other effect. We could, and --- perhaps should, separate out the flags that have some minor impact on --- program semantics and/or error behavior (e.g., assertions), but --- then we'd need to go to extra trouble (and an additional flag) --- to allow users to ignore the optimisation level even though that --- means ignoring some change. +-- | The set of flags which affect optimisation for the purposes of +-- recompilation avoidance. Specifically, these include flags which +-- affect code generation but not the semantics of the program. +-- +-- See Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags) optimisationFlags :: EnumSet GeneralFlag optimisationFlags = EnumSet.fromList [ Opt_CallArity @@ -503,7 +501,6 @@ optimisationFlags = EnumSet.fromList , Opt_SpecConstr , Opt_SpecConstrKeen , Opt_DoLambdaEtaExpansion - , Opt_IgnoreAsserts , Opt_DoEtaReduction , Opt_CaseMerge , Opt_CaseFolding @@ -513,16 +510,12 @@ optimisationFlags = EnumSet.fromList , Opt_EnableRewriteRules , Opt_RegsGraph , Opt_RegsIterative - , Opt_PedanticBottoms , Opt_LlvmTBAA - , Opt_LlvmFillUndefWithGarbage , Opt_IrrefutableTuples , Opt_CmmSink , Opt_CmmElimCommonBlocks , Opt_AsmShortcutting - , Opt_OmitYields , Opt_FunToThunk - , Opt_DictsStrict , Opt_DmdTxDictSel , Opt_Loopification , Opt_CfgBlocklayout @@ -531,8 +524,47 @@ optimisationFlags = EnumSet.fromList , Opt_WorkerWrapper , Opt_WorkerWrapperUnlift , Opt_SolveConstantDicts + ] + +-- | The set of flags which affect code generation and can change a program's +-- runtime behavior (other than performance). These include flags which affect: +-- +-- * user visible debugging information (e.g. info table provenance) +-- * the ability to catch runtime errors (e.g. -fignore-asserts) +-- * the runtime result of the program (e.g. -fomit-yields) +-- * which code or interface file declarations are emitted +-- +-- We also considered placing flags which affect asympototic space behavior +-- (e.g. -ffull-laziness) however this would mean that changing optimisation +-- levels would trigger recompilation even with -fignore-optim-changes, +-- regressing #13604. +-- +-- Also, arguably Opt_IgnoreAsserts should be here as well; however, we place +-- it instead in 'optimisationFlags' since it is implied by @-O[12]@ and +-- therefore would also break #13604. +-- +codeGenFlags :: EnumSet GeneralFlag +codeGenFlags = EnumSet.fromList + [ -- Flags that affect runtime result + Opt_EagerBlackHoling + , Opt_ExcessPrecision + , Opt_DictsStrict + , Opt_PedanticBottoms + , Opt_OmitYields + + -- Flags that affect generated code + , Opt_ExposeAllUnfoldings + , Opt_NoTypeableBinds + + -- Flags that affect catching of runtime errors , Opt_CatchNonexhaustiveCases - , Opt_IgnoreAsserts + , Opt_LlvmFillUndefWithGarbage + , Opt_DoTagInferenceChecks + + -- Flags that affect debugging information + , Opt_DistinctConstructorTables + , Opt_InfoTableMap + , Opt_OrigThunkInfo ] data WarningFlag = ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -66,6 +66,7 @@ module GHC.Driver.Session ( makeDynFlagsConsistent, positionIndependent, optimisationFlags, + codeGenFlags, setFlagsFromEnvFile, pprDynFlagsDiff, flagSpecOf, @@ -3481,6 +3482,7 @@ fFlagsDeps = [ flagSpec "do-eta-reduction" Opt_DoEtaReduction, flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "orig-thunk-info" Opt_OrigThunkInfo, flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, ===================================== compiler/GHC/Iface/Recomp/Flags.hs ===================================== @@ -67,7 +67,10 @@ fingerprintDynFlags hsc_env this_mod nameio = ticky = map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag] - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters)) + -- Other flags which affect code generation + codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) + + flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters)) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -730,7 +730,8 @@ setupUpdate closure_info node body lbl | bh = mkBHUpdInfoLabel | otherwise = mkUpdInfoLabel - pushUpdateFrame lbl (CmmReg (CmmLocal node)) body + pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -738,7 +739,8 @@ setupUpdate closure_info node body ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf node - ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } + ; pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body } else do {tickyUpdateFrameOmitted; body} } @@ -754,8 +756,7 @@ pushUpdateFrame lbl updatee body = do updfr <- getUpdFrameOff profile <- getProfile - let - hdr = fixedHdrSize profile + let hdr = fixedHdrSize profile frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) -- emitUpdateFrame (CmmStackSlot Old frame) lbl updatee @@ -773,6 +774,47 @@ emitUpdateFrame frame lbl updatee = do emitStore (cmmOffset platform frame off_updatee) updatee initUpdFrameProf frame +----------------------------------------------------------------------------- +-- Original thunk info table frames +-- +-- Note [Original thunk info table frames] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very +-- useful to know which thunks the program is in the process of evaluating. +-- However, in the case of updateable thunks this can be very difficult +-- to determine since the process of blackholing overwrites the thunk's +-- info table pointer. +-- +-- To help in such situations we provide the -forig-thunk-info flag. This enables +-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to +-- accompany each update frame. As the name suggests, this frame captures the +-- the original info table of the thunk being updated. The entry code for these +-- frames has no operational effects; the frames merely exist as breadcrumbs +-- for debugging. + +pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode () +pushOrigThunkInfoFrame closure_info body = do + cfg <- getStgToCmmConfig + if stgToCmmOrigThunkInfo cfg + then do_it + else body + where + orig_itbl = mkLblExpr (closureInfoLabel closure_info) + do_it = do + updfr <- getUpdFrameOff + profile <- getProfile + let platform = profilePlatform profile + hdr = fixedHdrSize profile + orig_info_frame_sz = + hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile) + off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (profileConstants profile) + frame_off = updfr + orig_info_frame_sz + frame = CmmStackSlot Old frame_off + -- + emitStore frame (mkLblExpr mkOrigThunkInfoLabel) + emitStore (cmmOffset platform frame off_orig_info) orig_itbl + withUpdFrameOff frame_off body + ----------------------------------------------------------------------------- -- Entering a CAF -- ===================================== compiler/GHC/StgToCmm/Config.hs ===================================== @@ -49,6 +49,7 @@ data StgToCmmConfig = StgToCmmConfig , stgToCmmFastPAPCalls :: !Bool -- ^ , stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled , stgToCmmEagerBlackHole :: !Bool -- ^ + , stgToCmmOrigThunkInfo :: !Bool -- ^ Push @stg_orig_thunk_info@ frames during thunk update. , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See note [Mapping -- Info Tables to Source Positions] , stgToCmmOmitYields :: !Bool -- ^ true means omit heap checks when no allocation is performed ===================================== docs/users_guide/debugging.rst ===================================== @@ -1072,6 +1072,18 @@ Checking for consistency cases. This is helpful when debugging demand analysis or type checker bugs which can sometimes manifest as segmentation faults. +.. ghc-flag:: -forig-thunk-info + :shortdesc: Generate ``stg_orig_thunk_info`` stack frames on thunk entry + :type: dynamic + + When debugging cyclic thunks it can be helpful to know the original + info table of a thunk being evaluated. This flag enables code generation logic + to facilitate this, producing a ``stg_orig_thunk_info`` stack frame alongside + the usual update frame; such ``orig_thunk`` frames have no operational + effect but capture the original info table of the updated thunk for inspection + by debugging tools. See ``Note [Original thunk info table frames]`` in + ``GHC.StgToCmm.Bind`` for details. + .. ghc-flag:: -fcheck-prim-bounds :shortdesc: Instrument array primops with bounds checks. :type: dynamic ===================================== rts/StgMiscClosures.cmm ===================================== @@ -45,6 +45,17 @@ import CLOSURE stg_ret_t_info; import CLOSURE stg_ret_v_info; #endif +/* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */ +INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL, + W_ info_ptr, + W_ thunk_info_ptr) + /* no args => explicit stack */ +{ + unwind Sp = W_[Sp + WDS(2)]; + Sp_adj(2); + jump %ENTRY_CODE(Sp(0)) [*]; // NB. all registers live! +} + /* ---------------------------------------------------------------------------- Stack underflow ------------------------------------------------------------------------- */ ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -261,6 +261,13 @@ typedef struct _StgUpdateFrame { StgClosure *updatee; } StgUpdateFrame; +// Thunk update frame +// +// Closure types: RET_SMALL +typedef struct _StgOrigThunkInfoFrame { + StgHeader header; + StgInfoTable *info_ptr; +} StgOrigThunkInfoFrame; // Closure types: RET_SMALL typedef struct { ===================================== testsuite/tests/driver/T13914/T13914.stdout ===================================== @@ -5,11 +5,11 @@ main: Assertion failed CallStack (from HasCallStack): assert, called at main.hs:3:8 in main:Main With -fignore-asserts -[1 of 2] Compiling Main ( main.hs, main.o ) [Optimisation flags changed] +[1 of 2] Compiling Main ( main.hs, main.o ) [Flags changed] [2 of 2] Linking main [Objects changed] OK Without -fignore-asserts -[1 of 2] Compiling Main ( main.hs, main.o ) [Optimisation flags changed] +[1 of 2] Compiling Main ( main.hs, main.o ) [Flags changed] [2 of 2] Linking main [Objects changed] main: Assertion failed CallStack (from HasCallStack): ===================================== utils/deriveConstants/Main.hs ===================================== @@ -437,6 +437,7 @@ wanteds os = concat ,structField Both "StgEntCounter" "entry_count" ,closureSize Both "StgUpdateFrame" + ,closureSize Both "StgOrigThunkInfoFrame" ,closureSize C "StgCatchFrame" ,closureSize C "StgStopFrame" ,closureSize C "StgDeadThreadFrame" @@ -479,6 +480,7 @@ wanteds os = concat ,structSize C "StgTSOProfInfo" ,closureField Both "StgUpdateFrame" "updatee" + ,closureField Both "StgOrigThunkInfoFrame" "info_ptr" ,closureField C "StgCatchFrame" "handler" ,closureField C "StgCatchFrame" "exceptions_blocked" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/09fb21d748fbc5d6805dcf8e260c16b2ef686fcf...3d32cad7947b22dd753200dbce82039ea86db794 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/09fb21d748fbc5d6805dcf8e260c16b2ef686fcf...3d32cad7947b22dd753200dbce82039ea86db794 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 18:49:16 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 09 May 2023 14:49:16 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: testsuite: Add test for atomicSwapIORef Message-ID: <645a95ac7300a_38ffdac056ce741240098@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b970e64f by Ben Gamari at 2023-05-09T08:41:33-04:00 testsuite: Add test for atomicSwapIORef - - - - - 81cfefd2 by Ben Gamari at 2023-05-09T08:41:53-04:00 compiler: Implement atomicSwapIORef with xchg As requested by @treeowl in CLC#139. - - - - - 6b29154d by Ben Gamari at 2023-05-09T08:41:53-04:00 Make atomicSwapMutVar# an inline primop - - - - - 43bd5308 by doyougnu at 2023-05-09T14:49:08-04:00 JS: add GHC.JS.Optimizer, remove RTS.Printer, add Linker.Opt This MR changes some simple optimizations and is a first step in re-architecting the JS backend pipeline to add the optimizer. In particular it: - removes simple peep hole optimizations from `GHC.StgToJS.Printer` and removes that module - adds module `GHC.JS.Optimizer` - defines the same peep hole opts that were removed only now they are `Syntax -> Syntax` transformations rather than `Syntax -> JS code` optimizations - hooks the optimizer into code gen - adds FuncStat and ForStat constructors to the backend. Working Ticket: - #22736 Related MRs: - MR !10142 - MR !10000 ------------------------- Metric Decrease: CoOpt_Read ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T12707 T13253 T13253-spj T15164 T17516 T18140 T18282 T18698a T18698b T18923 T1969 T19695 T20049 T3064 T5321FD T5321Fun T783 T9198 T9233 T9630 ------------------------- - - - - - 05efe298 by Krzysztof Gogolewski at 2023-05-09T14:49:09-04:00 Add a regression test for #21050 - - - - - d412b167 by Ben Gamari at 2023-05-09T14:49:10-04:00 nonmoving: Account for mutator allocations in bytes_allocated Previously we failed to account direct mutator allocations into the nonmoving heap against the mutator's allocation limit and `cap->total_allocated`. This only manifests during CAF evaluation (since we allocate the CAF's blackhole directly into the nonmoving heap). Fixes #23312. - - - - - 30 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/JS/Make.hs - + compiler/GHC/JS/Optimizer.hs - compiler/GHC/JS/Ppr.hs - compiler/GHC/JS/Syntax.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/JS/Unsat/Syntax.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Printer.hs → compiler/GHC/StgToJS/Linker/Opt.hs - compiler/GHC/StgToJS/Object.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Rts/Rts.hs - compiler/ghc.cabal.in - libraries/base/GHC/IORef.hs - + libraries/base/tests/AtomicSwapIORef.hs - + libraries/base/tests/AtomicSwapIORef.stdout - libraries/base/tests/all.T - rts/include/Cmm.h - rts/sm/NonMovingAllocate.c - rts/sm/Storage.c - rts/sm/Storage.h - + testsuite/tests/javascript/opt/all.T - + testsuite/tests/javascript/opt/deadCodeElim.hs - + testsuite/tests/javascript/opt/deadCodeElim.stdout - testsuite/tests/linters/notes.stdout - + testsuite/tests/th/T21050.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7c1e9eba9a5597bcee3914637dfe77cedd4dda8...d412b16742d187ad3e3f3a97dc3e2954c2abbb49 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f7c1e9eba9a5597bcee3914637dfe77cedd4dda8...d412b16742d187ad3e3f3a97dc3e2954c2abbb49 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 19:38:38 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 15:38:38 -0400 Subject: [Git][ghc/ghc][wip/ci-interface-stability] 384 commits: Add clangd flag to include generated header files Message-ID: <645aa13eb5ff7_38ffdac43fea201275486@gitlab.mail> Ben Gamari pushed to branch wip/ci-interface-stability at Glasgow Haskell Compiler / GHC Commits: 16adc349 by Sven Tennie at 2023-02-14T11:26:31-05:00 Add clangd flag to include generated header files This enables clangd to correctly check C files that import Rts.h. (The added include directory contains ghcautoconf.h et. al.) - - - - - c399ccd9 by amesgen at 2023-02-14T11:27:14-05:00 Mention new `Foreign.Marshal.Pool` implementation in User's Guide - - - - - b9282cf7 by Ben Gamari at 2023-02-14T11:27:50-05:00 upload_ghc_libs: More control over which packages to operate on Here we add a `--skip` flag to `upload_ghc_libs`, making it easier to limit which packages to upload. This is often necessary when one package is not uploadable (e.g. see #22740). - - - - - aa3a262d by PHO at 2023-02-14T11:28:29-05:00 Assume platforms support rpaths if they use either ELF or Mach-O Not only Linux, Darwin, and FreeBSD support rpaths. Determine the usability of rpaths based on the object format, not on OS. - - - - - 47716024 by PHO at 2023-02-14T11:29:09-05:00 RTS linker: Improve compatibility with NetBSD 1. Hint address to NetBSD mmap(2) has a different semantics from that of Linux. When a hint address is provided, mmap(2) searches for a free region at or below the hint but *never* above it. This means we can't reliably search for free regions incrementally on the userland, especially when ASLR is enabled. Let the kernel do it for us if we don't care where the mapped address is going to be. 2. NetBSD not only hates to map pages as rwx, but also disallows to switch pages from rw- to r-x unless the intention is declared when pages are initially requested. This means we need a new MemoryAccess mode for pages that are going to be changed to r-x. - - - - - 11de324a by Li-yao Xia at 2023-02-14T11:29:49-05:00 base: Move changelog entry to its place - - - - - 75930424 by Ben Gamari at 2023-02-14T11:30:27-05:00 nativeGen/AArch64: Emit Atomic{Read,Write} inline Previously the AtomicRead and AtomicWrite operations were emitted as out-of-line calls. However, these tend to be very important for performance, especially the RELAXED case (which only exists for ThreadSanitizer checking). Fixes #22115. - - - - - d6411d6c by Andreas Klebinger at 2023-02-14T11:31:04-05:00 Fix some correctness issues around tag inference when targeting the bytecode generator. * Let binders are now always assumed untagged for bytecode. * Imported referenced are now always assumed to be untagged for bytecode. Fixes #22840 - - - - - 9fb4ca89 by sheaf at 2023-02-14T11:31:49-05:00 Introduce warning for loopy superclass solve Commit aed1974e completely re-engineered the treatment of loopy superclass dictionaries in instance declarations. Unfortunately, it has the potential to break (albeit in a rather minor way) user code. To alleviate migration concerns, this commit re-introduces the old behaviour. Any reliance on this old behaviour triggers a warning, controlled by `-Wloopy-superclass-solve`. The warning text explains that GHC might produce bottoming evidence, and provides a migration strategy. This allows us to provide a graceful migration period, alerting users when they are relying on this unsound behaviour. Fixes #22912 #22891 #20666 #22894 #22905 - - - - - 1928c7f3 by Cheng Shao at 2023-02-14T11:32:26-05:00 rts: make it possible to change mblock size on 32-bit targets The MBLOCK_SHIFT macro must be the single source of truth for defining the mblock size, and changing it should only affect performance, not correctness. This patch makes it truly possible to reconfigure mblock size, at least on 32-bit targets, by fixing places which implicitly relied on the previous MBLOCK_SHIFT constant. Fixes #22901. - - - - - 78aa3b39 by Simon Hengel at 2023-02-14T11:33:06-05:00 Update outdated references to notes - - - - - e8baecd2 by meooow25 at 2023-02-14T11:33:49-05:00 Documentation: Improve Foldable1 documentation * Explain foldrMap1, foldlMap1, foldlMap1', and foldrMap1' in greater detail, the text is mostly adapted from documentation of Foldable. * Describe foldr1, foldl1, foldl1' and foldr1' in terms of the above functions instead of redoing the full explanation. * Small updates to documentation of fold1, foldMap1 and toNonEmpty, again adapting from Foldable. * Update the foldMap1 example to lists instead of Sum since this is recommended for lazy right-associative folds. Fixes #22847 - - - - - 85a1a575 by romes at 2023-02-14T11:34:25-05:00 fix: Mark ghci Prelude import as implicit Fixes #22829 In GHCi, we were creating an import declaration for Prelude but we were not setting it as an implicit declaration. Therefore, ghci's import of Prelude triggered -Wmissing-import-lists. Adds regression test T22829 to testsuite - - - - - 3b019a7a by Cheng Shao at 2023-02-14T11:35:03-05:00 compiler: fix generateCgIPEStub for no-tables-next-to-code builds generateCgIPEStub already correctly implements the CmmTick finding logic for when tables-next-to-code is on/off, but it used the wrong predicate to decide when to switch between the two. Previously it switches based on whether the codegen is unregisterised, but there do exist registerised builds that disable tables-next-to-code! This patch corrects that problem. Fixes #22896. - - - - - 08c0822c by doyougnu at 2023-02-15T00:16:39-05:00 docs: release notes, user guide: add js backend Follow up from #21078 - - - - - 79d8fd65 by Bryan Richter at 2023-02-15T00:17:15-05:00 Allow failure in nightly-x86_64-linux-deb10-no_tntc-validate See #22343 - - - - - 9ca51f9e by Cheng Shao at 2023-02-15T00:17:53-05:00 rts: add the rts_clearMemory function This patch adds the rts_clearMemory function that does its best to zero out unused RTS memory for a wasm backend use case. See the comment above rts_clearMemory() prototype declaration for more detailed explanation. Closes #22920. - - - - - 26df73fb by Oleg Grenrus at 2023-02-15T22:20:57-05:00 Add -single-threaded flag to force single threaded rts This is the small part of implementing https://github.com/ghc-proposals/ghc-proposals/pull/240 - - - - - 631c6c72 by Cheng Shao at 2023-02-16T06:43:09-05:00 docs: add a section for the wasm backend Fixes #22658 - - - - - 1878e0bd by Bryan Richter at 2023-02-16T06:43:47-05:00 tests: Mark T12903 fragile everywhere See #21184 - - - - - b9420eac by Bryan Richter at 2023-02-16T06:43:47-05:00 Mark all T5435 variants as fragile See #22970. - - - - - df3d94bd by Sylvain Henry at 2023-02-16T06:44:33-05:00 Testsuite: mark T13167 as fragile for JS (#22921) - - - - - 324e925b by Sylvain Henry at 2023-02-16T06:45:15-05:00 JS: disable debugging info for heap objects - - - - - 518af814 by Josh Meredith at 2023-02-16T10:16:32-05:00 Factor JS Rts generation for h$c{_,0,1,2} into h$c{n} and improve name caching - - - - - 34cd308e by Ben Gamari at 2023-02-16T10:17:08-05:00 base: Note move of GHC.Stack.CCS.whereFrom to GHC.InfoProv in changelog Fixes #22883. - - - - - 12965aba by Simon Peyton Jones at 2023-02-16T10:17:46-05:00 Narrow the dont-decompose-newtype test Following #22924 this patch narrows the test that stops us decomposing newtypes. The key change is the use of noGivenNewtypeReprEqs in GHC.Tc.Solver.Canonical.canTyConApp. We went to and fro on the solution, as you can see in #22924. The result is carefully documented in Note [Decomoposing newtype equalities] On the way I had revert most of commit 3e827c3f74ef76d90d79ab6c4e71aa954a1a6b90 Author: Richard Eisenberg <rae at cs.brynmawr.edu> Date: Mon Dec 5 10:14:02 2022 -0500 Do newtype unwrapping in the canonicaliser and rewriter See Note [Unwrap newtypes first], which has the details. It turns out that (a) 3e827c3f makes GHC behave worse on some recursive newtypes (see one of the tests on this commit) (b) the finer-grained test (namely noGivenNewtypeReprEqs) renders 3e827c3f unnecessary - - - - - 5b038888 by Bodigrim at 2023-02-16T10:18:24-05:00 Documentation: add an example of SPEC usage - - - - - 681e0e8c by sheaf at 2023-02-16T14:09:56-05:00 No default finalizer exception handler Commit cfc8e2e2 introduced a mechanism for handling of exceptions that occur during Handle finalization, and 372cf730 set the default handler to print out the error to stderr. However, #21680 pointed out we might not want to set this by default, as it might pollute users' terminals with unwanted information. So, for the time being, the default handler discards the exception. Fixes #21680 - - - - - b3ac17ad by Matthew Pickering at 2023-02-16T14:10:31-05:00 unicode: Don't inline bitmap in generalCategory generalCategory contains a huge literal string but is marked INLINE, this will duplicate the string into any use site of generalCategory. In particular generalCategory is used in functions like isSpace and the literal gets inlined into this function which makes it massive. https://github.com/haskell/core-libraries-committee/issues/130 Fixes #22949 ------------------------- Metric Decrease: T4029 T18304 ------------------------- - - - - - 8988eeef by sheaf at 2023-02-16T20:32:27-05:00 Expand synonyms in RoughMap We were failing to expand type synonyms in the function GHC.Core.RoughMap.typeToRoughMatchLookupTc, even though the RoughMap infrastructure crucially relies on type synonym expansion to work. This patch adds the missing type-synonym expansion. Fixes #22985 - - - - - 3dd50e2f by Matthew Pickering at 2023-02-16T20:33:03-05:00 ghcup-metadata: Add test artifact Add the released testsuite tarball to the generated ghcup metadata. - - - - - c6a967d9 by Matthew Pickering at 2023-02-16T20:33:03-05:00 ghcup-metadata: Use Ubuntu and Rocky bindists Prefer to use the Ubuntu 20.04 and 18.04 binary distributions on Ubuntu and Linux Mint. Prefer to use the Rocky 8 binary distribution on unknown distributions. - - - - - be0b7209 by Matthew Pickering at 2023-02-17T09:37:16+00:00 Add INLINABLE pragmas to `generic*` functions in Data.OldList These functions are * recursive * overloaded So it's important to add an `INLINABLE` pragma to each so that they can be specialised at the use site when the specific numeric type is known. Adding these pragmas improves the LazyText replicate benchmark (see https://gitlab.haskell.org/ghc/ghc/-/issues/22886#note_481020) https://github.com/haskell/core-libraries-committee/issues/129 - - - - - a203ad85 by Sylvain Henry at 2023-02-17T15:59:16-05:00 Merge libiserv with ghci `libiserv` serves no purpose. As it depends on `ghci` and doesn't have more dependencies than the `ghci` package, its code could live in the `ghci` package too. This commit also moves most of the code from the `iserv` program into the `ghci` package as well so that it can be reused. This is especially useful for the implementation of TH for the JS backend (#22261, !9779). - - - - - 7080a93f by Simon Peyton Jones at 2023-02-20T12:06:32+01:00 Improve GHC.Tc.Gen.App.tcInstFun It wasn't behaving right when inst_final=False, and the function had no type variables f :: Foo => Int Rather a corner case, but we might as well do it right. Fixes #22908 Unexpectedly, three test cases (all using :type in GHCi) got slightly better output as a result: T17403, T14796, T12447 - - - - - 2592ab69 by Cheng Shao at 2023-02-20T10:35:30-05:00 compiler: fix cost centre profiling breakage in wasm NCG due to incorrect register mapping The wasm NCG used to map CCCS to a wasm global, based on the observation that CCCS is a transient register that's already handled by thread state load/store logic, so it doesn't need to be backed by the rCCCS field in the register table. Unfortunately, this is wrong, since even when Cmm execution hasn't yielded back to the scheduler, the Cmm code may call enterFunCCS, which does use rCCCS. This breaks cost centre profiling in a subtle way, resulting in inaccurate stack traces in some test cases. The fix is simple though: just remove the CCCS mapping. - - - - - 26243de1 by Alexis King at 2023-02-20T15:27:17-05:00 Handle top-level Addr# literals in the bytecode compiler Fixes #22376. - - - - - 0196cc2b by romes at 2023-02-20T15:27:52-05:00 fix: Explicitly flush stdout on plugin Because of #20791, the plugins tests often fail. This is a temporary fix to stop the tests from failing due to unflushed outputs on windows and the explicit flush should be removed when #20791 is fixed. - - - - - 4327d635 by Ryan Scott at 2023-02-20T20:44:34-05:00 Don't generate datacon wrappers for `type data` declarations Data constructor wrappers only make sense for _value_-level data constructors, but data constructors for `type data` declarations only exist at the _type_ level. This patch does the following: * The criteria in `GHC.Types.Id.Make.mkDataConRep` for whether a data constructor receives a wrapper now consider whether or not its parent data type was declared with `type data`, omitting a wrapper if this is the case. * Now that `type data` data constructors no longer receive wrappers, there is a spot of code in `refineDefaultAlt` that panics when it encounters a value headed by a `type data` type constructor. I've fixed this with a special case in `refineDefaultAlt` and expanded `Note [Refine DEFAULT case alternatives]` to explain why we do this. Fixes #22948. - - - - - 96dc58b9 by Ryan Scott at 2023-02-20T20:44:35-05:00 Treat type data declarations as empty when checking pattern-matching coverage The data constructors for a `type data` declaration don't exist at the value level, so we don't want GHC to warn users to match on them. Fixes #22964. - - - - - ff8e99f6 by Ryan Scott at 2023-02-20T20:44:35-05:00 Disallow `tagToEnum#` on `type data` types We don't want to allow users to conjure up values of a `type data` type using `tagToEnum#`, as these simply don't exist at the value level. - - - - - 8e765aff by Bodigrim at 2023-02-21T12:03:24-05:00 Bump submodule text to 2.0.2 - - - - - 172ff88f by Georgi Lyubenov at 2023-02-21T18:35:56-05:00 GHC proposal 496 - Nullary record wildcards This patch implements GHC proposal 496, which allows record wildcards to be used for nullary constructors, e.g. data A = MkA1 | MkA2 { fld1 :: Int } f :: A -> Int f (MkA1 {..}) = 0 f (MkA2 {..}) = fld1 To achieve this, we add arity information to the record field environment, so that we can accept a constructor which has no fields while continuing to reject non-record constructors with more than 1 field. See Note [Nullary constructors and empty record wildcards], as well as the more general overview in Note [Local constructor info in the renamer], both in the newly introduced GHC.Types.ConInfo module. Fixes #22161 - - - - - f70a0239 by sheaf at 2023-02-21T18:36:35-05:00 ghc-prim: levity-polymorphic array equality ops This patch changes the pointer-equality comparison operations in GHC.Prim.PtrEq to work with arrays of unlifted values, e.g. sameArray# :: forall {l} (a :: TYPE (BoxedRep l)). Array# a -> Array# a -> Int# Fixes #22976 - - - - - 9296660b by Andreas Klebinger at 2023-02-21T23:58:05-05:00 base: Correct @since annotation for FP<->Integral bit cast operations. Fixes #22708 - - - - - f11d9c27 by romes at 2023-02-21T23:58:42-05:00 fix: Update documentation links Closes #23008 Additionally batches some fixes to pointers to the Note [Wired-in units], and a typo in said note. - - - - - fb60339f by Bryan Richter at 2023-02-23T14:45:17+02:00 Propagate failure if unable to push notes - - - - - 8e170f86 by Alexis King at 2023-02-23T16:59:22-05:00 rts: Fix `prompt#` when profiling is enabled This commit also adds a new -Dk RTS option to the debug RTS to assist debugging continuation captures. Currently, the printed information is quite minimal, but more can be added in the future if it proves to be useful when debugging future issues. fixes #23001 - - - - - e9e7a00d by sheaf at 2023-02-23T17:00:01-05:00 Explicit migration timeline for loopy SC solving This patch updates the warning message introduced in commit 9fb4ca89bff9873e5f6a6849fa22a349c94deaae to specify an explicit migration timeline: GHC will no longer support this constraint solving mechanism starting from GHC 9.10. Fixes #22912 - - - - - 4eb9c234 by Sylvain Henry at 2023-02-24T17:27:45-05:00 JS: make some arithmetic primops faster (#22835) Don't use BigInt for wordAdd2, mulWord32, and timesInt32. Co-authored-by: Matthew Craven <5086-clyring at users.noreply.gitlab.haskell.org> - - - - - 92e76483 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump terminfo submodule to 0.4.1.6 - - - - - f229db14 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump unix submodule to 2.8.1.0 - - - - - 47bd48c1 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump deepseq submodule to 1.4.8.1 - - - - - d2012594 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump directory submodule to 1.3.8.1 - - - - - df6f70d1 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump process submodule to v1.6.17.0 - - - - - 4c869e48 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump hsc2hs submodule to 0.68.8 - - - - - 81d96642 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump array submodule to 0.5.4.0 - - - - - 6361f771 by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump Cabal submodule to 3.9 pre-release - - - - - 4085fb6c by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump filepath submodule to 1.4.100.1 - - - - - 2bfad50f by Ben Gamari at 2023-02-24T17:28:20-05:00 Bump haskeline submodule to 0.8.2.1 - - - - - fdc89a8d by Ben Gamari at 2023-02-24T21:29:32-05:00 gitlab-ci: Run nix-build with -v0 This significantly cuts down on the amount of noise in the job log. Addresses #22861. - - - - - 69fb0b13 by Aaron Allen at 2023-02-24T21:30:10-05:00 Fix ParallelListComp out of scope suggestion This patch makes it so vars from one block of a parallel list comprehension are not in scope in a subsequent block during type checking. This was causing GHC to emit a faulty suggestion when an out of scope variable shared the occ name of a var from a different block. Fixes #22940 - - - - - ece092d0 by Simon Peyton Jones at 2023-02-24T21:30:45-05:00 Fix shadowing bug in prepareAlts As #23012 showed, GHC.Core.Opt.Simplify.Utils.prepareAlts was using an OutType to construct an InAlt. When shadowing is in play, this is outright wrong. See Note [Shadowing in prepareAlts]. - - - - - 7825fef9 by Sylvain Henry at 2023-02-24T21:31:25-05:00 JS: Store CI perf results (fix #22923) - - - - - b56025f4 by Gergő Érdi at 2023-02-27T13:34:22+00:00 Don't specialise incoherent instance applications Using incoherent instances, there can be situations where two occurrences of the same overloaded function at the same type use two different instances (see #22448). For incoherently resolved instances, we must mark them with `nospec` to avoid the specialiser rewriting one to the other. This marking is done during the desugaring of the `WpEvApp` wrapper. Fixes #22448 Metric Increase: T15304 - - - - - d0c7bbed by Tom Ellis at 2023-02-27T20:04:07-05:00 Fix SCC grouping example - - - - - f84a8cd4 by Bryan Richter at 2023-02-28T05:58:37-05:00 Mark setnumcapabilities001 fragile - - - - - 29a04d6e by Bryan Richter at 2023-02-28T05:58:37-05:00 Allow nightly-x86_64-linux-deb10-validate+thread_sanitizer to fail See #22520 - - - - - 9fa54572 by Cheng Shao at 2023-02-28T05:59:15-05:00 ghc-prim: fix hs_cmpxchg64 function prototype hs_cmpxchg64 must return a StgWord64, otherwise incorrect runtime results of 64-bit MO_Cmpxchg will appear in 32-bit unregisterised builds, which go unnoticed at compile-time due to C implicit casting in .hc files. - - - - - 0c200ab7 by Simon Peyton Jones at 2023-02-28T11:10:31-05:00 Account for local rules in specImports As #23024 showed, in GHC.Core.Opt.Specialise.specImports, we were generating specialisations (a locally-define function) for imported functions; and then generating specialisations for those locally-defined functions. The RULE for the latter should be attached to the local Id, not put in the rules-for-imported-ids set. Fix is easy; similar to what happens in GHC.HsToCore.addExportFlagsAndRules - - - - - 8b77f9bf by Sylvain Henry at 2023-02-28T11:11:21-05:00 JS: fix for overlap with copyMutableByteArray# (#23033) The code wasn't taking into account some kind of overlap. cgrun070 has been extended to test the missing case. - - - - - 239202a2 by Sylvain Henry at 2023-02-28T11:12:03-05:00 Testsuite: replace some js_skip with req_cmm req_cmm is more informative than js_skip - - - - - 7192ef91 by Simon Peyton Jones at 2023-02-28T18:54:59-05:00 Take more care with unlifted bindings in the specialiser As #22998 showed, we were floating an unlifted binding to top level, which breaks a Core invariant. The fix is easy, albeit a little bit conservative. See Note [Care with unlifted bindings] in GHC.Core.Opt.Specialise - - - - - bb500e2a by Simon Peyton Jones at 2023-02-28T18:55:35-05:00 Account for TYPE vs CONSTRAINT in mkSelCo As #23018 showed, in mkRuntimeRepCo we need to account for coercions between TYPE and COERCION. See Note [mkRuntimeRepCo] in GHC.Core.Coercion. - - - - - 79ffa170 by Ben Gamari at 2023-03-01T04:17:20-05:00 hadrian: Add dependency from lib/settings to mk/config.mk In 81975ef375de07a0ea5a69596b2077d7f5959182 we attempted to fix #20253 by adding logic to the bindist Makefile to regenerate the `settings` file from information gleaned by the bindist `configure` script. However, this fix had no effect as `lib/settings` is shipped in the binary distribution (to allow in-place use of the binary distribution). As `lib/settings` already existed and its rule declared no dependencies, `make` would fail to use the added rule to regenerate it. Fix this by explicitly declaring a dependency from `lib/settings` on `mk/config.mk`. Fixes #22982. - - - - - a2a1a1c0 by Sebastian Graf at 2023-03-01T04:17:56-05:00 Revert the main payload of "Make `drop` and `dropWhile` fuse (#18964)" This reverts the bits affecting fusion of `drop` and `dropWhile` of commit 0f7588b5df1fc7a58d8202761bf1501447e48914 and keeps just the small refactoring unifying `flipSeqTake` and `flipSeqScanl'` into `flipSeq`. It also adds a new test for #23021 (which was the reason for reverting) as well as adds a clarifying comment to T18964. Fixes #23021, unfixes #18964. Metric Increase: T18964 Metric Decrease: T18964 - - - - - cf118e2f by Simon Peyton Jones at 2023-03-01T04:18:33-05:00 Refine the test for naughty record selectors The test for naughtiness in record selectors is surprisingly subtle. See the revised Note [Naughty record selectors] in GHC.Tc.TyCl.Utils. Fixes #23038. - - - - - 86f240ca by romes at 2023-03-01T04:19:10-05:00 fix: Consider strictness annotation in rep_bind Fixes #23036 - - - - - 1ed573a5 by Richard Eisenberg at 2023-03-02T22:42:06-05:00 Don't suppress *all* Wanteds Code in GHC.Tc.Errors.reportWanteds suppresses a Wanted if its rewriters have unfilled coercion holes; see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. But if we thereby suppress *all* errors that's really confusing, and as #22707 shows, GHC goes on without even realising that the program is broken. Disaster. This MR arranges to un-suppress them all if they all get suppressed. Close #22707 - - - - - 8919f341 by Luite Stegeman at 2023-03-02T22:42:45-05:00 Check for platform support for JavaScript foreign imports GHC was accepting `foreign import javascript` declarations on non-JavaScript platforms. This adds a check so that these are only supported on an platform that supports the JavaScript calling convention. Fixes #22774 - - - - - db83f8bb by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Statically assert alignment of Capability In #22965 we noticed that changes in the size of `Capability` can result in unsound behavior due to the `align` pragma claiming an alignment which we don't in practice observe. Avoid this by statically asserting that the size is a multiple of the alignment. - - - - - 5f7a4a6d by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Introduce stgMallocAlignedBytes - - - - - 8a6f745d by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Correctly align Capability allocations Previously we failed to tell the C allocator that `Capability`s needed to be aligned, resulting in #22965. Fixes #22965. Fixes #22975. - - - - - 5464c73f by Ben Gamari at 2023-03-02T22:43:22-05:00 rts: Drop no-alignment special case for Windows For reasons that aren't clear, we were previously not giving Capability the same favorable alignment on Windows that we provided on other platforms. Fix this. - - - - - a86aae8b by Matthew Pickering at 2023-03-02T22:43:59-05:00 constant folding: Correct type of decodeDouble_Int64 rule The first argument is Int64# unconditionally, so we better produce something of that type. This fixes a core lint error found in the ad package. Fixes #23019 - - - - - 68dd64ff by Zubin Duggal at 2023-03-02T22:44:35-05:00 ncg/aarch64: Handle MULTILINE_COMMENT identically as COMMENTs Commit 7566fd9de38c67360c090f828923d41587af519c with the fix for #22798 was incomplete as it failed to handle MULTILINE_COMMENT pseudo-instructions, and didn't completly fix the compiler panics when compiling with `-fregs-graph`. Fixes #23002 - - - - - 2f97c861 by Simon Peyton Jones at 2023-03-02T22:45:11-05:00 Get the right in-scope set in etaBodyForJoinPoint Fixes #23026 - - - - - 45af8482 by David Feuer at 2023-03-03T11:40:47-05:00 Export getSolo from Data.Tuple Proposed in [CLC proposal #113](https://github.com/haskell/core-libraries-committee/issues/113) and [approved by the CLC](https://github.com/haskell/core-libraries-committee/issues/113#issuecomment-1452452191) - - - - - 0c694895 by David Feuer at 2023-03-03T11:40:47-05:00 Document getSolo - - - - - bd0536af by Simon Peyton Jones at 2023-03-03T11:41:23-05:00 More fixes for `type data` declarations This MR fixes #23022 and #23023. Specifically * Beef up Note [Type data declarations] in GHC.Rename.Module, to make invariant (I1) explicit, and to name the several wrinkles. And add references to these specific wrinkles. * Add a Lint check for invariant (I1) above. See GHC.Core.Lint.checkTypeDataConOcc * Disable the `caseRules` for dataToTag# for `type data` values. See Wrinkle (W2c) in the Note above. Fixes #23023. * Refine the assertion in dataConRepArgTys, so that it does not complain about the absence of a wrapper for a `type data` constructor Fixes #23022. Acked-by: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - 858f34d5 by Oleg Grenrus at 2023-03-04T01:13:55+02:00 Add decideSymbol, decideChar, decideNat, decTypeRep, decT and hdecT These all type-level equality decision procedures. Implementes a CLC proposal https://github.com/haskell/core-libraries-committee/issues/98 - - - - - bf43ba92 by Simon Peyton Jones at 2023-03-04T01:18:23-05:00 Add test for T22793 - - - - - c6e1f3cd by Chris Wendt at 2023-03-04T03:35:18-07:00 Fix typo in docs referring to threadLabel - - - - - 232cfc24 by Simon Peyton Jones at 2023-03-05T19:57:30-05:00 Add regression test for #22328 - - - - - 5ed77deb by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Enable response files for linker if supported - - - - - 1e0f6c89 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Synchronize `configure.ac` and `distrib/configure.ac.in` - - - - - 70560952 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Fix `hadrian/bindist/config.mk.in` … as suggested by @bgamari - - - - - b042b125 by sheaf at 2023-03-06T17:06:50-05:00 Apply 1 suggestion(s) to 1 file(s) - - - - - 674b6b81 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Try to create somewhat portable `ld` command I cannot figure out a good way to generate an `ld` command that works on both Linux and macOS. Normally you'd use something like `AC_LINK_IFELSE` for this purpose (I think), but that won't let us test response file support. - - - - - 83b0177e by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Quote variables … as suggested by @bgamari - - - - - 845f404d by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Fix configure failure on alpine linux - - - - - c56a3ae6 by Gabriella Gonzalez at 2023-03-06T17:06:50-05:00 Small fixes to configure script - - - - - cad5c576 by Andrei Borzenkov at 2023-03-06T17:07:33-05:00 Convert diagnostics in GHC.Rename.Module to proper TcRnMessage (#20115) I've turned almost all occurrences of TcRnUnknownMessage in GHC.Rename.Module module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnIllegalInstanceHeadDecl TcRnUnexpectedStandaloneDerivingDecl TcRnUnusedVariableInRuleDecl TcRnUnexpectedStandaloneKindSig TcRnIllegalRuleLhs TcRnBadAssocRhs TcRnDuplicateRoleAnnot TcRnDuplicateKindSig TcRnIllegalDerivStrategy TcRnIllegalMultipleDerivClauses TcRnNoDerivStratSpecified TcRnStupidThetaInGadt TcRnBadImplicitSplice TcRnShadowedTyVarNameInFamResult TcRnIncorrectTyVarOnLhsOfInjCond TcRnUnknownTyVarsOnRhsOfInjCond Was introduced one helper type: RuleLhsErrReason - - - - - c6432eac by Apoorv Ingle at 2023-03-06T23:26:12+00:00 Constraint simplification loop now depends on `ExpansionFuel` instead of a boolean flag for `CDictCan.cc_pend_sc`. Pending givens get a fuel of 3 while Wanted and quantified constraints get a fuel of 1. This helps pending given constraints to keep up with pending wanted constraints in case of `UndecidableSuperClasses` and superclass expansions while simplifying the infered type. Adds 3 dynamic flags for controlling the fuels for each type of constraints `-fgivens-expansion-fuel` for givens `-fwanteds-expansion-fuel` for wanteds and `-fqcs-expansion-fuel` for quantified constraints Fixes #21909 Added Tests T21909, T21909b Added Note [Expanding Recursive Superclasses and ExpansionFuel] - - - - - a5afc8ab by Bodigrim at 2023-03-06T22:51:01-05:00 Documentation: describe laziness of several function from Data.List - - - - - fa559c28 by Ollie Charles at 2023-03-07T20:56:21+00:00 Add `Data.Functor.unzip` This function is currently present in `Data.List.NonEmpty`, but `Data.Functor` is a better home for it. This change was discussed and approved by the CLC at https://github.com/haskell/core-libraries-committee/issues/88. - - - - - 2aa07708 by MorrowM at 2023-03-07T21:22:22-05:00 Fix documentation for traceWith and friends - - - - - f3ff7cb1 by David Binder at 2023-03-08T01:24:17-05:00 Remove utils/hpc subdirectory and its contents - - - - - cf98e286 by David Binder at 2023-03-08T01:24:17-05:00 Add git submodule for utils/hpc - - - - - 605fbbb2 by David Binder at 2023-03-08T01:24:18-05:00 Update commit for utils/hpc git submodule - - - - - 606793d4 by David Binder at 2023-03-08T01:24:18-05:00 Update commit for utils/hpc git submodule - - - - - 4158722a by Sylvain Henry at 2023-03-08T01:24:58-05:00 linker: fix linking with aligned sections (#23066) Take section alignment into account instead of assuming 16 bytes (which is wrong when the section requires 32 bytes, cf #23066). - - - - - 1e0d8fdb by Greg Steuck at 2023-03-08T08:59:05-05:00 Change hostSupportsRPaths to report False on OpenBSD OpenBSD does support -rpath but ghc build process relies on some related features that don't work there. See ghc/ghc#23011 - - - - - bed3a292 by Alexis King at 2023-03-08T08:59:53-05:00 bytecode: Fix bitmaps for BCOs used to tag tuples and prim call args fixes #23068 - - - - - 321d46d9 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Drop redundant prototype - - - - - abb6070f by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix style - - - - - be278901 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Deduplicate assertion - - - - - b9034639 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Fix type issues in Sparks.h Adds explicit casts to satisfy a C++ compiler. - - - - - da7b2b94 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts: Use release ordering when storing thread labels Since this makes the ByteArray# visible from other cores. - - - - - 5b7f6576 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/BlockAlloc: Allow disabling of internal assertions These can be quite expensive and it is sometimes useful to compile a DEBUG RTS without them. - - - - - 6283144f by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/Sanity: Mark pinned_object_blocks - - - - - 9b528404 by Ben Gamari at 2023-03-08T15:02:30-05:00 rts/Sanity: Look at nonmoving saved_filled lists - - - - - 0edc5438 by Ben Gamari at 2023-03-08T15:02:30-05:00 Evac: Squash data race in eval_selector_chain - - - - - 7eab831a by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Clarify implementation This makes the intent of this implementation a bit clearer. - - - - - 532262b9 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Clarify comment - - - - - bd9cd84b by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Add missing no-op in busy-wait loop - - - - - c4e6bfc8 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't push empty arrays to update remembered set Previously the write barrier of resizeSmallArray# incorrectly handled resizing of zero-sized arrays, pushing an invalid pointer to the update remembered set. Fixes #22931. - - - - - 92227b60 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix handling of weak pointers This fixes an interaction between aging and weak pointer handling which prevented the finalization of some weak pointers. In particular, weak pointers could have their keys incorrectly marked by the preparatory collector, preventing their finalization by the subsequent concurrent collection. While in the area, we also significantly improve the assertions regarding weak pointers. Fixes #22327. - - - - - ba7e7972 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Sanity check nonmoving large objects and compacts - - - - - 71b038a1 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Sanity check mutable list Assert that entries in the nonmoving generation's generational remembered set (a.k.a. mutable list) live in nonmoving generation. - - - - - 99d144d5 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't show occupancy if we didn't collect live words - - - - - 81d6cc55 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Fix tracking of FILLED_SWEEPING segments Previously we only updated the state of the segment at the head of each allocator's filled list. - - - - - 58e53bc4 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Assert state of swept segments - - - - - 2db92e01 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Handle new closures in nonmovingIsNowAlive We must conservatively assume that new closures are reachable since we are not guaranteed to mark such blocks. - - - - - e4c3249f by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Don't clobber update rem sets of old capabilities Previously `storageAddCapabilities` (called by `setNumCapabilities`) would clobber the update remembered sets of existing capabilities when increasing the capability count. Fix this by only initializing the update remembered sets of the newly-created capabilities. Fixes #22927. - - - - - 1b069671 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Add missing write barriers in selector optimisation This fixes the selector optimisation, adding a few write barriers which are necessary for soundness. See the inline comments for details. Fixes #22930. - - - - - d4032690 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Post-sweep sanity checking - - - - - 0baa8752 by Ben Gamari at 2023-03-08T15:02:30-05:00 nonmoving: Avoid n_caps race - - - - - 5d3232ba by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Don't push if nonmoving collector isn't enabled - - - - - 0a7eb0aa by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Be more paranoid in segment tracking Previously we left various segment link pointers dangling. None of this wrong per se, but it did make it harder than necessary to debug. - - - - - 7c817c0a by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Sync-phase mark budgeting Here we significantly improve the bound on sync phase pause times by imposing a limit on the amount of work that we can perform during the sync. If we find that we have exceeded our marking budget then we allow the mutators to resume, return to concurrent marking, and try synchronizing again later. Fixes #22929. - - - - - ce22a3e2 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Allow pinned gen0 objects to be WEAK keys - - - - - 78746906 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Reenable assertion - - - - - b500867a by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Move current segment array into Capability The current segments are conceptually owned by the mutator, not the collector. Consequently, it was quite tricky to prove that the mutator would not race with the collect due to this shared state. It turns out that such races are possible: when resizing the current segment array we may concurrently try to take a heap census. This will attempt to walk the current segment array, causing a data race. Fix this by moving the current segment array into `Capability`, where it belongs. Fixes #22926. - - - - - 56e669c1 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Fix Note references Some references to Note [Deadlock detection under the non-moving collector] were missing an article. - - - - - 4a7650d7 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts/Sanity: Fix block count assertion with non-moving collector The nonmoving collector does not use `oldest_gen->blocks` to track its block list. However, it nevertheless updates `oldest_gen->n_blocks` to ensure that its size is accounted for by the storage manager. Consequently, we must not attempt to assert consistency between the two. - - - - - 96a5aaed by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Don't call prepareUnloadCheck When the nonmoving GC is in use we do not call `checkUnload` (since we don't unload code) and therefore should not call `prepareUnloadCheck`, lest we run into assertions. - - - - - 6c6674ca by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Encapsulate block allocator spinlock This makes it a bit easier to add instrumentation on this spinlock while debugging. - - - - - e84f7167 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Skip some tests when sanity checking is enabled - - - - - 3ae0f368 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Fix unregisterised build - - - - - 4eb9d06b by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Ensure that sanity checker accounts for saved_filled segments - - - - - f0cf384d by Ben Gamari at 2023-03-08T15:02:31-05:00 hadrian: Add +boot_nonmoving_gc flavour transformer For using GHC bootstrapping to validate the non-moving GC. - - - - - 581e58ac by Ben Gamari at 2023-03-08T15:02:31-05:00 gitlab-ci: Add job bootstrapping with nonmoving GC - - - - - 487a8b58 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Move allocator into new source file - - - - - 8f374139 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Split out nonmovingAllocateGC - - - - - 662b6166 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Only run T22795* in the normal way It doesn't make sense to run these in multiple ways as they merely test whether `-threaded`/`-single-threaded` flags. - - - - - 0af21dfa by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Rename clear_segment(_free_blocks)? To reflect the fact that these are to do with the nonmoving collector, now since they are exposed no longer static. - - - - - 7bcb192b by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Fix incorrect STATIC_INLINE This should be INLINE_HEADER lest we get unused declaration warnings. - - - - - f1fd3ffb by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Mark ffi023 as broken due to #23089 - - - - - a57f12b3 by Ben Gamari at 2023-03-08T15:02:31-05:00 testsuite: Skip T7160 in the nonmoving way Finalization order is different under the nonmoving collector. - - - - - f6f12a36 by Ben Gamari at 2023-03-08T15:02:31-05:00 rts: Capture GC configuration in a struct The number of distinct arguments passed to GarbageCollect was getting a bit out of hand. - - - - - ba73a807 by Ben Gamari at 2023-03-08T15:02:31-05:00 nonmoving: Non-concurrent collection - - - - - 7c813d06 by Alexis King at 2023-03-08T15:03:10-05:00 hadrian: Fix flavour compiler stage options off-by-one error !9193 pointed out that ghcDebugAssertions was supposed to be a predicate on the stage of the built compiler, but in practice it was a predicate on the stage of the compiler used to build. Unfortunately, while it fixed that issue for ghcDebugAssertions, it documented every other similar option as behaving the same way when in fact they all used the old behavior. The new behavior of ghcDebugAssertions seems more intuitive, so this commit changes the interpretation of every other option to match. It also improves the enableProfiledGhc and debugGhc flavour transformers by making them more selective about which stages in which they build additional library/RTS ways. - - - - - f97c7f6d by Luite Stegeman at 2023-03-09T09:52:09-05:00 Delete created temporary subdirectories at end of session. This patch adds temporary subdirectories to the list of paths do clean up at the end of the GHC session. This fixes warnings about non-empty temporary directories. Fixes #22952 - - - - - 9ea719f2 by Apoorv Ingle at 2023-03-09T09:52:45-05:00 Fixes #19627. Previously the solver failed with an unhelpful "solver reached too may iterations" error. With the fix for #21909 in place we no longer have the possibility of generating such an error if we have `-fconstraint-solver-iteration` > `-fgivens-fuel > `-fwanteds-fuel`. This is true by default, and the said fix also gives programmers a knob to control how hard the solver should try before giving up. This commit adds: * Reference to ticket #19627 in the Note [Expanding Recursive Superclasses and ExpansionFuel] * Test `typecheck/should_fail/T19627.hs` for regression purposes - - - - - ec2d93eb by Sebastian Graf at 2023-03-10T10:18:54-05:00 DmdAnal: Fix a panic on OPAQUE and trivial/PAP RHS (#22997) We should not panic in `add_demands` (now `set_lam_dmds`), because that code path is legimitely taken for OPAQUE PAP bindings, as in T22997. Fixes #22997. - - - - - 5b4628ae by Sylvain Henry at 2023-03-10T10:19:34-05:00 JS: remove dead code for old integer-gmp - - - - - bab23279 by Josh Meredith at 2023-03-10T23:24:49-05:00 JS: Fix implementation of MK_JSVAL - - - - - ec263a59 by Sebastian Graf at 2023-03-10T23:25:25-05:00 Simplify: Move `wantEtaExpansion` before expensive `do_eta_expand` check There is no need to run arity analysis and what not if we are not in a Simplifier phase that eta-expands or if we don't want to eta-expand the expression in the first place. Purely a refactoring with the goal of improving compiler perf. - - - - - 047e9d4f by Josh Meredith at 2023-03-13T03:56:03+00:00 JS: fix implementation of forceBool to use JS backend syntax - - - - - 559a4804 by Sebastian Graf at 2023-03-13T07:31:23-04:00 Simplifier: `countValArgs` should not count Type args (#23102) I observed miscompilations while working on !10088 caused by this. Fixes #23102. Metric Decrease: T10421 - - - - - 536d1f90 by Matthew Pickering at 2023-03-13T14:04:49+00:00 Bump Win32 to 2.13.4.0 Updates Win32 submodule - - - - - ee17001e by Ben Gamari at 2023-03-13T21:18:24-04:00 ghc-bignum: Drop redundant include-dirs field - - - - - c9c26cd6 by Teo Camarasu at 2023-03-16T12:17:50-04:00 Fix BCO creation setting caps when -j > -N * Remove calls to 'setNumCapabilities' in 'createBCOs' These calls exist to ensure that 'createBCOs' can benefit from parallelism. But this is not the right place to call `setNumCapabilities`. Furthermore the logic differs from that in the driver causing the capability count to be raised and lowered at each TH call if -j > -N. * Remove 'BCOOpts' No longer needed as it was only used to thread the job count down to `createBCOs` Resolves #23049 - - - - - 5ddbf5ed by Teo Camarasu at 2023-03-16T12:17:50-04:00 Add changelog entry for #23049 - - - - - 6e3ce9a4 by Ben Gamari at 2023-03-16T12:18:26-04:00 configure: Fix FIND_CXX_STD_LIB test on Darwin Annoyingly, Darwin's <cstddef> includes <version> and APFS is case-insensitive. Consequently, it will end up #including the `VERSION` file generated by the `configure` script on the second and subsequent runs of the `configure` script. See #23116. - - - - - 19d6d039 by sheaf at 2023-03-16T21:31:22+01:00 ghci: only keep the GlobalRdrEnv in ModInfo The datatype GHC.UI.Info.ModInfo used to store a ModuleInfo, which includes a TypeEnv. This can easily cause space leaks as we have no way of forcing everything in a type environment. In GHC, we only use the GlobalRdrEnv, which we can force completely. So we only store that instead of a fully-fledged ModuleInfo. - - - - - 73d07c6e by Torsten Schmits at 2023-03-17T14:36:49-04:00 Add structured error messages for GHC.Tc.Utils.Backpack Tracking ticket: #20119 MR: !10127 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. One occurrence, when handing a nested error from the interface loading machinery, was omitted. It will be handled by a subsequent changeset that addresses interface errors. - - - - - a13affce by Andrei Borzenkov at 2023-03-21T11:17:17-04:00 Rename () into Unit, (,,...,,) into Tuple<n> (#21294) This patch implements a part of GHC Proposal #475. The key change is in GHC.Tuple.Prim: - data () = () - data (a,b) = (a,b) - data (a,b,c) = (a,b,c) ... + data Unit = () + data Tuple2 a b = (a,b) + data Tuple3 a b c = (a,b,c) ... And the rest of the patch makes sure that Unit and Tuple<n> are pretty-printed as () and (,,...,,) in various contexts. Updates the haddock submodule. Co-authored-by: Vladislav Zavialov <vlad.z.4096 at gmail.com> - - - - - 23642bf6 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: fix some wrongs in the eventlog format documentation - - - - - 90159773 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: explain the BLOCK_MARKER event - - - - - ab1c25e8 by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add BlockedOnMVarRead thread status in eventlog encodings - - - - - 898afaef by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add TASK_DELETE event in eventlog encodings - - - - - bb05b4cc by Adam Sandberg Ericsson at 2023-03-21T11:17:53-04:00 docs: add WALL_CLOCK_TIME event in eventlog encodings - - - - - eeea0343 by Torsten Schmits at 2023-03-21T11:18:34-04:00 Add structured error messages for GHC.Tc.Utils.Env Tracking ticket: #20119 MR: !10129 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - be1d4be8 by Bodigrim at 2023-03-21T11:19:13-04:00 Document pdep / pext primops - - - - - e8b4aac4 by Alex Mason at 2023-03-21T18:11:04-04:00 Allow LLVM backend to use HDoc for faster file generation. Also remove the MetaStmt constructor from LlvmStatement and places the annotations into the Store statement. Includes “Implement a workaround for -no-asm-shortcutting bug“ (https://gitlab.haskell.org/ghc/ghc/-/commit/2fda9e0df886cc551e2cd6b9c2a384192bdc3045) - - - - - ea24360d by Luite Stegeman at 2023-03-21T18:11:44-04:00 Compute LambdaFormInfo when using JavaScript backend. CmmCgInfos is needed to write interface files, but the JavaScript backend does not generate it, causing "Name without LFInfo" warnings. This patch adds a conservative but always correct CmmCgInfos when the JavaScript backend is used. Fixes #23053 - - - - - 926ad6de by Simon Peyton Jones at 2023-03-22T01:03:08-04:00 Be more careful about quantification This MR is driven by #23051. It does several things: * It is guided by the generalisation plan described in #20686. But it is still far from a complete implementation of that plan. * Add Note [Inferred type with escaping kind] to GHC.Tc.Gen.Bind. This explains that we don't (yet, pending #20686) directly prevent generalising over escaping kinds. * In `GHC.Tc.Utils.TcMType.defaultTyVar` we default RuntimeRep and Multiplicity variables, beause we don't want to quantify over them. We want to do the same for a Concrete tyvar, but there is nothing sensible to default it to (unless it has kind RuntimeRep, in which case it'll be caught by an earlier case). So we promote instead. * Pure refactoring in GHC.Tc.Solver: * Rename decideMonoTyVars to decidePromotedTyVars, since that's what it does. * Move the actual promotion of the tyvars-to-promote from `defaultTyVarsAndSimplify` to `decidePromotedTyVars`. This is a no-op; just tidies up the code. E.g then we don't need to return the promoted tyvars from `decidePromotedTyVars`. * A little refactoring in `defaultTyVarsAndSimplify`, but no change in behaviour. * When making a TauTv unification variable into a ConcreteTv (in GHC.Tc.Utils.Concrete.makeTypeConcrete), preserve the occ-name of the type variable. This just improves error messages. * Kill off dead code: GHC.Tc.Utils.TcMType.newConcreteHole - - - - - 0ab0cc11 by Sylvain Henry at 2023-03-22T01:03:48-04:00 Testsuite: use appropriate predicate for ManyUbxSums test (#22576) - - - - - 048c881e by romes at 2023-03-22T01:04:24-04:00 fix: Incorrect @since annotations in GHC.TypeError Fixes #23128 - - - - - a1528b68 by Sylvain Henry at 2023-03-22T01:05:04-04:00 Testsuite: use req_interp predicate for T16318 (#22370) - - - - - ad765b6f by Sylvain Henry at 2023-03-22T01:05:04-04:00 Testsuite: use req_interp predicate for T20214 - - - - - e0b8eaf3 by Simon Peyton Jones at 2023-03-22T09:50:13+00:00 Refactor the constraint solver pipeline The big change is to put the entire type-equality solver into GHC.Tc.Solver.Equality, rather than scattering it over Canonical and Interact. Other changes * EqCt becomes its own data type, a bit like QCInst. This is great because EqualCtList is then just [EqCt] * New module GHC.Tc.Solver.Dict has come of the class-contraint solver. In due course it will be all. One step at a time. This MR is intended to have zero change in behaviour: it is a pure refactor. It opens the way to subsequent tidying up, we believe. - - - - - cedf9a3b by Torsten Schmits at 2023-03-22T15:31:18-04:00 Add structured error messages for GHC.Tc.Utils.TcMType Tracking ticket: #20119 MR: !10138 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 30d45e97 by Sylvain Henry at 2023-03-22T15:32:01-04:00 Testsuite: use js_skip for T2615 (#22374) - - - - - 8c98deba by Armando Ramirez at 2023-03-23T09:19:32-04:00 Optimized Foldable methods for Data.Functor.Compose Explicitly define length, elem, etc. in Foldable instance for Data.Functor.Compose Implementation of https://github.com/haskell/core-libraries-committee/issues/57 - - - - - bc066108 by Armando Ramirez at 2023-03-23T09:19:32-04:00 Additional optimized versions - - - - - 80fce576 by Bodigrim at 2023-03-23T09:19:32-04:00 Simplify minimum/maximum in instance Foldable (Compose f g) - - - - - 8cb88a5a by Bodigrim at 2023-03-23T09:19:32-04:00 Update changelog to mention changes to instance Foldable (Compose f g) - - - - - e1c8c41d by Torsten Schmits at 2023-03-23T09:20:13-04:00 Add structured error messages for GHC.Tc.TyCl.PatSyn Tracking ticket: #20117 MR: !10158 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - f932c589 by Adam Gundry at 2023-03-24T02:36:09-04:00 Allow WARNING pragmas to be controlled with custom categories Closes #17209. This implements GHC Proposal 541, allowing a WARNING pragma to be annotated with a category like so: {-# WARNING in "x-partial" head "This function is undefined on empty lists." #-} The user can then enable, disable and set the severity of such warnings using command-line flags `-Wx-partial`, `-Werror=x-partial` and so on. There is a new warning group `-Wextended-warnings` containing all these warnings. Warnings without a category are treated as if the category was `deprecations`, and are (still) controlled by the flags `-Wdeprecations` and `-Wwarnings-deprecations`. Updates Haddock submodule. - - - - - 0426515b by Adam Gundry at 2023-03-24T02:36:09-04:00 Move mention of warning groups change to 9.8.1 release notes - - - - - b8d783d2 by Ben Gamari at 2023-03-24T02:36:45-04:00 nativeGen/AArch64: Fix bitmask immediate predicate Previously the predicate for determining whether a logical instruction operand could be encoded as a bitmask immediate was far too conservative. This meant that, e.g., pointer untagged required five instructions whereas it should only require one. Fixes #23030. - - - - - 46120bb6 by Joachim Breitner at 2023-03-24T13:09:43-04:00 User's guide: Improve docs for -Wall previously it would list the warnings _not_ enabled by -Wall. That’s unnecessary round-about and was out of date. So let's just name the relevant warnings (based on `compiler/GHC/Driver/Flags.hs`). - - - - - 509d1f11 by Ben Gamari at 2023-03-24T13:10:20-04:00 codeGen/tsan: Disable instrumentation of unaligned stores There is some disagreement regarding the prototype of `__tsan_unaligned_write` (specifically whether it takes just the written address, or the address and the value as an argument). Moreover, I have observed crashes which appear to be due to it. Disable instrumentation of unaligned stores as a temporary mitigation. Fixes #23096. - - - - - 6a73655f by Li-yao Xia at 2023-03-25T00:02:44-04:00 base: Document GHC versions associated with past base versions in the changelog - - - - - 43bd7694 by Teo Camarasu at 2023-03-25T00:03:24-04:00 Add regression test for #17574 This test currently fails in the nonmoving way - - - - - f2d56bf7 by Teo Camarasu at 2023-03-25T00:03:24-04:00 fix: account for large and compact object stats with nonmoving gc Make sure that we keep track of the size of large and compact objects that have been moved onto the nonmoving heap. We keep track of their size and add it to the amount of live bytes in nonmoving segments to get the total size of the live nonmoving heap. Resolves #17574 - - - - - 7131b705 by David Feuer at 2023-03-25T00:04:04-04:00 Modify ThreadId documentation and comments For a long time, `GHC.Conc.Sync` has said ```haskell -- ToDo: data ThreadId = ThreadId (Weak ThreadId#) -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. ``` We are now actually capable of using `Weak# ThreadId#`, but the world has moved on. To support the `Show` and `Ord` instances, we'd need to store the thread ID number in the `ThreadId`. And it seems very difficult to continue to support `threadStatus` in that regime, since it needs to be able to explain how threads died. In addition, garbage collection of weak references can be quite expensive, and it would be hard to evaluate the cost over he whole ecosystem. As discussed in [this CLC issue](https://github.com/haskell/core-libraries-committee/issues/125), it doesn't seem very likely that we'll actually switch to weak references here. - - - - - c421bbbb by Ben Gamari at 2023-03-25T00:04:41-04:00 rts: Fix barriers of IND and IND_STATIC Previously IND and IND_STATIC lacked the acquire barriers enjoyed by BLACKHOLE. As noted in the (now updated) Note [Heap memory barriers], this barrier is critical to ensure that the indirectee is visible to the entering core. Fixes #22872. - - - - - 62fa7faa by Bodigrim at 2023-03-25T00:05:22-04:00 Improve documentation of atomicModifyMutVar2# - - - - - b2d14d0b by Cheng Shao at 2023-03-25T03:46:43-04:00 rts: use performBlockingMajorGC in hs_perform_gc and fix ffi023 This patch does a few things: - Add the missing RtsSymbols.c entry of performBlockingMajorGC - Make hs_perform_gc call performBlockingMajorGC, which restores previous behavior - Use hs_perform_gc in ffi023 - Remove rts_clearMemory() call in ffi023, it now works again in some test ways previously marked as broken. Fixes #23089 - - - - - d9ae24ad by Cheng Shao at 2023-03-25T03:46:44-04:00 testsuite: add the rts_clearMemory test case This patch adds a standalone test case for rts_clearMemory that mimics how it's typically used by wasm backend users and ensures this RTS API isn't broken by future RTS refactorings. Fixes #23901. - - - - - 80729d96 by Bodigrim at 2023-03-25T03:47:22-04:00 Improve documentation for resizing of byte arrays - - - - - c6ec4cd1 by Ben Gamari at 2023-03-25T20:23:47-04:00 rts: Don't rely on EXTERN_INLINE for slop-zeroing logic Previously we relied on calling EXTERN_INLINE functions defined in ClosureMacros.h from Cmm to zero slop. However, as far as I can tell, this is no longer safe to do in C99 as EXTERN_INLINE definitions may be emitted in each compilation unit. Fix this by explicitly declaring a new set of non-inline functions in ZeroSlop.c which can be called from Cmm and marking the ClosureMacros.h definitions as INLINE_HEADER. In the future we should try to eliminate EXTERN_INLINE. - - - - - c32abd4b by Ben Gamari at 2023-03-25T20:23:48-04:00 rts: Fix capability-count check in zeroSlop Previously `zeroSlop` examined `RtsFlags` to determine whether the program was single-threaded. This is wrong; a program may be started with `+RTS -N1` yet the process may later increase the capability count with `setNumCapabilities`. This lead to quite subtle and rare crashes. Fixes #23088. - - - - - 656d4cb3 by Ryan Scott at 2023-03-25T20:24:23-04:00 Add Eq/Ord instances for SSymbol, SChar, and SNat This implements [CLC proposal #148](https://github.com/haskell/core-libraries-committee/issues/148). - - - - - 4f93de88 by David Feuer at 2023-03-26T15:33:02-04:00 Update and expand atomic modification Haddocks * The documentation for `atomicModifyIORef` and `atomicModifyIORef'` were incomplete, and the documentation for `atomicModifyIORef` was out of date. Update and expand. * Remove a useless lazy pattern match in the definition of `atomicModifyIORef`. The pair it claims to match lazily was already forced by `atomicModifyIORef2`. - - - - - e1fb56b2 by David Feuer at 2023-03-26T15:33:41-04:00 Document the constructor name for lists Derived `Data` instances use raw infix constructor names when applicable. The `Data.Data [a]` instance, if derived, would have a constructor name of `":"`. However, it actually uses constructor name `"(:)"`. Document this peculiarity. See https://github.com/haskell/core-libraries-committee/issues/147 - - - - - c1f755c4 by Simon Peyton Jones at 2023-03-27T22:09:41+01:00 Make exprIsConApp_maybe a bit cleverer Addresses #23159. See Note Note [Exploit occ-info in exprIsConApp_maybe] in GHC.Core.SimpleOpt. Compile times go down very slightly, but always go down, never up. Good! Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -1.8% T15703(normal) -1.2% GOOD geo. mean -0.1% minimum -1.8% maximum +0.0% Metric Decrease: CoOpt_Singletons T15703 - - - - - 76bb4c58 by Ryan Scott at 2023-03-28T08:12:08-04:00 Add COMPLETE pragmas to TypeRep, SSymbol, SChar, and SNat This implements [CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149). - - - - - 3f374399 by sheaf at 2023-03-29T13:57:33+02:00 Handle records in the renamer This patch moves the field-based logic for disambiguating record updates to the renamer. The type-directed logic, scheduled for removal, remains in the typechecker. To do this properly (and fix the myriad of bugs surrounding the treatment of duplicate record fields), we took the following main steps: 1. Create GREInfo, a renamer-level equivalent to TyThing which stores information pertinent to the renamer. This allows us to uniformly treat imported and local Names in the renamer, as described in Note [GREInfo]. 2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which distinguished between normal names and field names, we now store simple Names in GlobalRdrElt, along with the new GREInfo information which allows us to recover the FieldLabel for record fields. 3. Add namespacing for record fields, within the OccNames themselves. This allows us to remove the mangling of duplicate field selectors. This change ensures we don't print mangled names to the user in error messages, and allows us to handle duplicate record fields in Template Haskell. 4. Move record disambiguation to the renamer, and operate on the level of data constructors instead, to handle #21443. The error message text for ambiguous record updates has also been changed to reflect that type-directed disambiguation is on the way out. (3) means that OccEnv is now a bit more complex: we first key on the textual name, which gives an inner map keyed on NameSpace: OccEnv a ~ FastStringEnv (UniqFM NameSpace a) Note that this change, along with (2), both increase the memory residency of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to regress somewhat in compile-time allocation. Even though (3) simplified a lot of code (in particular the treatment of field selectors within Template Haskell and in error messages), it came with one important wrinkle: in the situation of -- M.hs-boot module M where { data A; foo :: A -> Int } -- M.hs module M where { data A = MkA { foo :: Int } } we have that M.hs-boot exports a variable foo, which is supposed to match with the record field foo that M exports. To solve this issue, we add a new impedance-matching binding to M foo{var} = foo{fld} This mimics the logic that existed already for impedance-binding DFunIds, but getting it right was a bit tricky. See Note [Record field impedance matching] in GHC.Tc.Module. We also needed to be careful to avoid introducing space leaks in GHCi. So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in ModIface. This means stubbing out all the GREInfo fields, with the function forceGlobalRdrEnv. When we read it back in, we rehydrate with rehydrateGlobalRdrEnv. This robustly avoids any space leaks caused by retaining old type environments. Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063 Updates haddock submodule ------------------------- Metric Increase: MultiComponentModules MultiLayerModules MultiLayerModulesDefsGhci MultiLayerModulesNoCode T13701 T14697 hard_hole_fits ------------------------- - - - - - 4f1940f0 by sheaf at 2023-03-29T13:57:33+02:00 Avoid repeatedly shadowing in shadowNames This commit refactors GHC.Type.Name.Reader.shadowNames to first accumulate all the shadowing arising from the introduction of a new set of GREs, and then applies all the shadowing to the old GlobalRdrEnv in one go. - - - - - d246049c by sheaf at 2023-03-29T13:57:34+02:00 igre_prompt_env: discard "only-qualified" names We were unnecessarily carrying around names only available qualified in igre_prompt_env, violating the icReaderEnv invariant. We now get rid of these, as they aren't needed for the shadowing computation that igre_prompt_env exists for. Fixes #23177 ------------------------- Metric Decrease: T14052 T14052Type ------------------------- - - - - - 41a572f6 by Matthew Pickering at 2023-03-29T16:17:21-04:00 hadrian: Fix path to HpcParser.y The source for this project has been moved into a src/ folder so we also need to update this path. Fixes #23187 - - - - - b159e0e9 by doyougnu at 2023-03-30T01:40:08-04:00 js: split JMacro into JS eDSL and JS syntax This commit: Splits JExpr and JStat into two nearly identical DSLs: - GHC.JS.Syntax is the JMacro based DSL without unsaturation, i.e., a value cannot be unsaturated, or, a value of this DSL is a witness that a value of GHC.JS.Unsat has been saturated - GHC.JS.Unsat is the JMacro DSL from GHCJS with Unsaturation. Then all binary and outputable instances are changed to use GHC.JS.Syntax. This moves us closer to closing out #22736 and #22352. See #22736 for roadmap. ------------------------- Metric Increase: CoOpt_Read LargeRecord ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T10858 T11195 T11374 T11822 T12227 T12707 T13035 T13253 T13253-spj T13379 T14683 T15164 T15703 T16577 T17096 T17516 T17836 T18140 T18282 T18304 T18478 T18698a T18698b T18923 T1969 T19695 T20049 T21839c T3064 T4801 T5321FD T5321Fun T5631 T5642 T783 T9198 T9233 T9630 TcPlugin_RewritePerf WWRec ------------------------- - - - - - f4f1f14f by Sylvain Henry at 2023-03-30T01:40:49-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. Also used the opportunity to reenable 64-bit Word/Int tests - - - - - a5360490 by Ben Gamari at 2023-03-30T01:41:25-04:00 testsuite: Fix racing prints in T21465 As noted in #23155, we previously failed to add flushes necessary to ensure predictable output. Fixes #23155. - - - - - 98b5cf67 by Matthew Pickering at 2023-03-30T09:58:40+01:00 Revert "ghc-heap: remove wrong Addr# coercion (#23181)" This reverts commit f4f1f14f8009c3c120b8b963ec130cbbc774ec02. This fails to build with GHC-9.2 as a boot compiler. See #23195 for tracking this issue. - - - - - 61a2dfaa by Bodigrim at 2023-03-30T14:35:57-04:00 Add {-# WARNING #-} to Data.List.{head,tail} - - - - - 8f15c47c by Bodigrim at 2023-03-30T14:35:57-04:00 Fixes to accomodate Data.List.{head,tail} with {-# WARNING #-} - - - - - 7c7dbade by Bodigrim at 2023-03-30T14:35:57-04:00 Bump submodules - - - - - d2d8251b by Bodigrim at 2023-03-30T14:35:57-04:00 Fix tests - - - - - 3d38dcb6 by sheaf at 2023-03-30T14:35:57-04:00 Proxies for head and tail: review suggestions - - - - - 930edcfd by sheaf at 2023-03-30T14:36:33-04:00 docs: move RecordUpd changelog entry to 9.8 This was accidentally included in the 9.6 changelog instead of the 9.6 changelog. - - - - - 6f885e65 by sheaf at 2023-03-30T14:37:09-04:00 Add LANGUAGE GADTs to GHC.Rename.Env We need to enable this extension for the file to compile with ghc 9.2, as we are pattern matching on a GADT and this required the GADT extension to be enabled until 9.4. - - - - - 6d6a37a8 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: make lint-ci-config job fast again We don't pin our nixpkgs revision and tracks the default nixpkgs-unstable channel anyway. Instead of using haskell.packages.ghc924, we should be using haskell.packages.ghc92 to maximize the binary cache hit rate and make lint-ci-config job fast again. Also bumps the nix docker image to the latest revision. - - - - - ef1548c4 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: ensure that all non-i386 pipelines do parallel xz compression We can safely enable parallel xz compression for non-i386 pipelines. However, previously we didn't export XZ_OPT, so the xz process won't see it if XZ_OPT hasn't already been set in the current job. - - - - - 20432d16 by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: unset CROSS_EMULATOR for js job - - - - - 4a24dbbe by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: fix lint-testsuite job The list_broken make target will transitively depend on the calibrate.out target, which used STAGE1_GHC instead of TEST_HC. It really should be TEST_HC since that's what get passed in the gitlab CI config. - - - - - cea56ccc by Cheng Shao at 2023-03-30T18:42:56+00:00 ci: use alpine3_17-wasm image for wasm jobs Bump the ci-images dependency and use the new alpine3_17-wasm docker image for wasm jobs. - - - - - 79d0cb32 by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - e7392b4e by Ben Gamari at 2023-03-30T18:43:53+00:00 testsuite/driver: Normalize away differences in ghc executable name - - - - - ee160d06 by Ben Gamari at 2023-03-30T18:43:53+00:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - 30c84511 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: don't add optllvm way for wasm32 - - - - - f1beee36 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: normalize the .wasm extension - - - - - a984a103 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: strip the cross ghc prefix in output and error message - - - - - f7478d95 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: handle target executable extension - - - - - 8fe8b653 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: mypy typing error fixes This patch fixes some mypy typing errors which weren't caught in previous linting jobs. - - - - - 0149f32f by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: use context variable instead of thread-local variable This patch changes a thread-local variable to context variable instead, which works as intended when the testsuite transitions to use asyncio & coroutines instead of multi-threading to concurrently run test cases. Note that this also raises the minimum Python version to 3.7. - - - - - ea853ff0 by Cheng Shao at 2023-03-30T18:43:53+00:00 testsuite: asyncify the testsuite driver This patch refactors the testsuite driver, gets rid of multi-threading logic for running test cases concurrently, and uses asyncio & coroutines instead. This is not yak shaving for its own sake; the previous multi-threading logic is prone to livelock/deadlock conditions for some reason, even if the total number of threads is bounded to a thread pool's capacity. The asyncify change is an internal implementation detail of the testsuite driver and does not impact most GHC maintainers out there. The patch does not touch the .T files, test cases can be added/modified the exact same way as before. - - - - - 0077cb22 by Matthew Pickering at 2023-03-31T21:28:28-04:00 Add test for T23184 There was an outright bug, which Simon fixed in July 2021, as a little side-fix on a complicated patch: ``` commit 6656f0165a30fc2a22208532ba384fc8e2f11b46 Author: Simon Peyton Jones <simonpj at microsoft.com> Date: Fri Jul 23 23:57:01 2021 +0100 A bunch of changes related to eta reduction This is a large collection of changes all relating to eta reduction, originally triggered by #18993, but there followed a long saga. Specifics: ...lots of lines omitted... Other incidental changes * Fix a fairly long-standing outright bug in the ApplyToVal case of GHC.Core.Opt.Simplify.mkDupableContWithDmds. I was failing to take the tail of 'dmds' in the recursive call, which meant the demands were All Wrong. I have no idea why this has not caused problems before now. ``` Note this "Fix a fairly longstanding outright bug". This is the specific fix ``` @@ -3552,8 +3556,8 @@ mkDupableContWithDmds env dmds -- let a = ...arg... -- in [...hole...] a -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:_) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 ; (_, se', arg') <- simplArg env' dup se arg ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' ``` Ticket #23184 is a report of the bug that this diff fixes. - - - - - 62d25071 by mangoiv at 2023-04-01T04:20:01-04:00 [feat] make ($) representation polymorphic - this change was approved by the CLC in [1] following a CLC proposal [2] - make ($) representation polymorphic (adjust the type signature) - change ($) implementation to allow additional polymorphism - adjust the haddock of ($) to reflect these changes - add additional documentation to document these changes - add changelog entry - adjust tests (move now succeeding tests and adjust stdout of some tests) [1] https://github.com/haskell/core-libraries-committee/issues/132#issuecomment-1487456854 [2] https://github.com/haskell/core-libraries-committee/issues/132 - - - - - 77c33fb9 by Artem Pelenitsyn at 2023-04-01T04:20:41-04:00 User Guide: update copyright year: 2020->2023 - - - - - 3b5be05a by doyougnu at 2023-04-01T09:42:31-04:00 driver: Unit State Data.Map -> GHC.Unique.UniqMap In pursuit of #22426. The driver and unit state are major contributors. This commit also bumps the haddock submodule to reflect the API changes in UniqMap. ------------------------- Metric Decrease: MultiComponentModules MultiComponentModulesRecomp T10421 T10547 T12150 T12234 T12425 T13035 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T5837 T6048 T9198 ------------------------- - - - - - a84fba6e by Torsten Schmits at 2023-04-01T09:43:12-04:00 Add structured error messages for GHC.Tc.TyCl Tracking ticket: #20117 MR: !10183 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 6e2eb275 by doyougnu at 2023-04-01T18:27:56-04:00 JS: Linker: use saturated JExpr Follow on to MR!10142 in pursuit of #22736 - - - - - 3da69346 by sheaf at 2023-04-01T18:28:37-04:00 Improve haddocks of template-haskell Con datatype This adds a bit more information, in particular about the lists of constructors in the GadtC and RecGadtC cases. - - - - - 3b7bbb39 by sheaf at 2023-04-01T18:28:37-04:00 TH: revert changes to GadtC & RecGadtC Commit 3f374399 included a breaking-change to the template-haskell library when it made the GadtC and RecGadtC constructors take non-empty lists of names. As this has the potential to break many users' packages, we decided to revert these changes for now. - - - - - f60f6110 by Bodigrim at 2023-04-02T18:59:30-04:00 Rework documentation for data Char - - - - - 43ebd5dc by Bodigrim at 2023-04-02T19:00:09-04:00 cmm: implement parsing of MO_AtomicRMW from hand-written CMM files Fixes #23206 - - - - - ab9cd52d by Sylvain Henry at 2023-04-03T08:15:21-04:00 ghc-heap: remove wrong Addr# coercion (#23181) Conversion from Addr# to I# isn't correct with the JS backend. - - - - - 2b2afff3 by Matthew Pickering at 2023-04-03T08:15:58-04:00 hadrian: Update bootstrap plans for 9.2.6, 9.2.7, 9.4.4, 9.4.5, 9.6.1 Also fixes the ./generate_bootstrap_plans script which was recently broken We can hopefully drop the 9.2 plans soon but they still work so kept them around for now. - - - - - c2605e25 by Matthew Pickering at 2023-04-03T08:15:58-04:00 ci: Add job to test 9.6 bootstrapping - - - - - 53e4d513 by Krzysztof Gogolewski at 2023-04-03T08:16:35-04:00 hadrian: Improve option parsing Several options in Hadrian had their argument marked as optional (`OptArg`), but if the argument wasn't there they were just giving an error. It's more idiomatic to mark the argument as required instead; the code uses less Maybes, the parser can enforce that the argument is present, --help gives better output. - - - - - a8e36892 by Sylvain Henry at 2023-04-03T08:17:16-04:00 JS: fix issues with FD api support - Add missing implementations for fcntl_read/write/lock - Fix fdGetMode These were found while implementing TH in !9779. These functions must be used somehow by the external interpreter code. - - - - - 8b092910 by Haskell-mouse at 2023-04-03T19:31:26-04:00 Convert diagnostics in GHC.Rename.HsType to proper TcRnMessage I've turned all occurrences of TcRnUnknownMessage in GHC.Rename.HsType module into a proper TcRnMessage. Instead, these TcRnMessage messages were introduced: TcRnDataKindsError TcRnUnusedQuantifiedTypeVar TcRnIllegalKindSignature TcRnUnexpectedPatSigType TcRnSectionPrecedenceError TcRnPrecedenceParsingError TcRnIllegalKind TcRnNegativeNumTypeLiteral TcRnUnexpectedKindVar TcRnBindMultipleVariables TcRnBindVarAlreadyInScope - - - - - 220a7a48 by Krzysztof Gogolewski at 2023-04-03T19:32:02-04:00 Fixes around unsafeCoerce# 1. `unsafeCoerce#` was documented in `GHC.Prim`. But since the overhaul in 74ad75e87317, `unsafeCoerce#` is no longer defined there. I've combined the documentation in `GHC.Prim` with the `Unsafe.Coerce` module. 2. The documentation of `unsafeCoerce#` stated that you should not cast a function to an algebraic type, even if you later cast it back before applying it. But ghci was doing that type of cast, as can be seen with 'ghci -ddump-ds' and typing 'x = not'. I've changed it to use Any following the documentation. - - - - - 9095e297 by Matthew Craven at 2023-04-04T01:04:10-04:00 Add a few more memcpy-ish primops * copyMutableByteArrayNonOverlapping# * copyAddrToAddr# * copyAddrToAddrNonOverlapping# * setAddrRange# The implementations of copyBytes, moveBytes, and fillBytes in base:Foreign.Marshal.Utils now use these new primops, which can cause us to work a bit harder generating code for them, resulting in the metric increase in T21839c observed by CI on some architectures. But in exchange, we get better code! Metric Increase: T21839c - - - - - f7da530c by Matthew Craven at 2023-04-04T01:04:10-04:00 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. - - - - - cd00e321 by sheaf at 2023-04-04T01:04:50-04:00 Relax assertion in varToRecFieldOcc When using Template Haskell, it is possible to re-parent a field OccName belonging to one data constructor to another data constructor. The lsp-types package did this in order to "extend" a data constructor with additional fields. This ran into an assertion in 'varToRecFieldOcc'. This assertion can simply be relaxed, as the resulting splices are perfectly sound. Fixes #23220 - - - - - eed0d930 by Sylvain Henry at 2023-04-04T11:09:15-04:00 GHCi.RemoteTypes: fix doc and avoid unsafeCoerce (#23201) - - - - - 071139c3 by Ryan Scott at 2023-04-04T11:09:51-04:00 Make INLINE pragmas for pattern synonyms work with TH Previously, the code for converting `INLINE <name>` pragmas from TH splices used `vNameN`, which assumed that `<name>` must live in the variable namespace. Pattern synonyms, on the other hand, live in the constructor namespace. I've fixed the issue by switching to `vcNameN` instead, which works for both the variable and constructor namespaces. Fixes #23203. - - - - - 7c16f3be by Krzysztof Gogolewski at 2023-04-04T17:13:00-04:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). - - - - - c165f079 by sheaf at 2023-04-04T17:13:40-04:00 Add testcase for #23192 This issue around solving of constraints arising from superclass expansion using other constraints also borned from superclass expansion was the topic of commit aed1974e. That commit made sure we don't emit a "redundant constraint" warning in a situation in which removing the constraint would cause errors. Fixes #23192 - - - - - d1bb16ed by Ben Gamari at 2023-04-06T03:40:45-04:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 - - - - - 04b80850 by Brandon Chinn at 2023-04-06T03:41:21-04:00 Fix reverse flag for -Wunsupported-llvm-version - - - - - 0c990e13 by Pierre Le Marre at 2023-04-06T10:16:29+00:00 Add release note for GHC.Unicode refactor in base-4.18. Also merge CLC proposal 130 in base-4.19 with CLC proposal 59 in base-4.18 and add proper release date. - - - - - cbbfb283 by Alex Dixon at 2023-04-07T18:27:45-04:00 Improve documentation for ($) (#22963) - - - - - 5193c2b0 by Alex Dixon at 2023-04-07T18:27:45-04:00 Remove trailing whitespace from ($) commentary - - - - - b384523b by Sebastian Graf at 2023-04-07T18:27:45-04:00 Adjust wording wrt representation polymorphism of ($) - - - - - 6a788f0a by Torsten Schmits at 2023-04-07T22:29:28-04:00 Add structured error messages for GHC.Tc.TyCl.Utils Tracking ticket: #20117 MR: !10251 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 3ba77b36 by sheaf at 2023-04-07T22:30:07-04:00 Renamer: don't call addUsedGRE on an exact Name When looking up a record field in GHC.Rename.Env.lookupRecFieldOcc, we could end up calling addUsedGRE on an exact Name, which would then lead to a panic in the bestImport function: it would be incapable of processing a GRE which is not local but also not brought into scope by any imports (as it is referred to by its unique instead). Fixes #23240 - - - - - bc4795d2 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add support for -debug in the testsuite Confusingly, GhcDebugged referred to GhcDebugAssertions. - - - - - b7474b57 by Krzysztof Gogolewski at 2023-04-11T19:24:54-04:00 Add missing cases in -Di prettyprinter Fixes #23142 - - - - - 6c392616 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: make WasmCodeGenM an instance of MonadUnique - - - - - 05d26a65 by Cheng Shao at 2023-04-11T19:25:31-04:00 compiler: apply cmm node-splitting for wasm backend This patch applies cmm node-splitting for wasm32 NCG, which is required when handling irreducible CFGs. Fixes #23237. - - - - - f1892cc0 by Bodigrim at 2023-04-11T19:26:09-04:00 Set base 'maintainer' field to CLC - - - - - ecf22da3 by Simon Peyton Jones at 2023-04-11T19:26:45-04:00 Clarify a couple of Notes about 'nospec' - - - - - ebd8918b by Oleg Grenrus at 2023-04-12T12:32:57-04:00 Allow generation of TTH syntax with TH In other words allow generation of typed splices and brackets with Untyped Template Haskell. That is useful in cases where a library is build with TTH in mind, but we still want to generate some auxiliary declarations, where TTH cannot help us, but untyped TH can. Such example is e.g. `staged-sop` which works with TTH, but we would like to derive `Generic` declarations with TH. An alternative approach is to use `unsafeCodeCoerce`, but then the derived `Generic` instances would be type-checked only at use sites, i.e. much later. Also `-ddump-splices` output is quite ugly: user-written instances would use TTH brackets, not `unsafeCodeCoerce`. This commit doesn't allow generating of untyped template splices and brackets with untyped TH, as I don't know why one would want to do that (instead of merging the splices, e.g.) - - - - - 690d0225 by Rodrigo Mesquita at 2023-04-12T12:33:33-04:00 Add regression test for #23229 - - - - - 59321879 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quotRem rules (#22152) case quotRemInt# x y of (# q, _ #) -> body ====> case quotInt# x y of q -> body case quotRemInt# x y of (# _, r #) -> body ====> case remInt# x y of r -> body - - - - - 4dd02122 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Add quot folding rule (#22152) (x / l1) / l2 l1 and l2 /= 0 l1*l2 doesn't overflow ==> x / (l1 * l2) - - - - - 1148ac72 by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make Int64/Word64 division ok for speculation too. Only when the divisor is definitely non-zero. - - - - - 8af401cc by Sylvain Henry at 2023-04-13T08:50:33-04:00 Make WordQuotRem2Op ok-for-speculation too - - - - - 27d2978e by Josh Meredith at 2023-04-13T08:51:09-04:00 Base/JS: GHC.JS.Foreign.Callback module (issue 23126) * Add the Callback module for "exporting" Haskell functions to be available to plain JavaScript code * Fix some primitives defined in GHC.JS.Prim * Add a JavaScript section to the user guide with instructions on how to use the JavaScript FFI, building up to using Callbacks to interact with the browser * Add tests for the JavaScript FFI and Callbacks - - - - - a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 3e3a6be4 by Ben Gamari at 2023-05-08T12:15:19+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 78c8dc50 by Torsten Schmits at 2023-05-08T21:41:51-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 0e2df4c9 by Bryan Richter at 2023-05-09T12:03:35+03:00 Fix up rules for ghcup-metadata-nightly-push - - - - - 81bbfec7 by Ben Gamari at 2023-05-09T15:38:24-04:00 testsuite: Add test to catch changes in core libraries This adds testing infrastructure to ensure that changes in core libraries (e.g. `base` and `ghc-prim`) are caught in CI. - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/generate_job_metadata - .gitlab/generate_jobs - .gitlab/jobs.yaml - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - .gitlab/rel_eng/upload_ghc_libs.py - .gitlab/test-metrics.sh - .gitmodules - CODEOWNERS - cabal.project-reinstall - compile_flags.txt - compiler/GHC.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/Uniques.hs-boot - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e4e3caf8415d00b0f69716785222068bb37f5b45...81bbfec71cda8254b613fd710fb8f7a4596f1d6e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e4e3caf8415d00b0f69716785222068bb37f5b45...81bbfec71cda8254b613fd710fb8f7a4596f1d6e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 22:39:39 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 09 May 2023 18:39:39 -0400 Subject: [Git][ghc/ghc][master] 3 commits: testsuite: Add test for atomicSwapIORef Message-ID: <645acbab9cb86_38ffdad6fba1f41384239@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b970e64f by Ben Gamari at 2023-05-09T08:41:33-04:00 testsuite: Add test for atomicSwapIORef - - - - - 81cfefd2 by Ben Gamari at 2023-05-09T08:41:53-04:00 compiler: Implement atomicSwapIORef with xchg As requested by @treeowl in CLC#139. - - - - - 6b29154d by Ben Gamari at 2023-05-09T08:41:53-04:00 Make atomicSwapMutVar# an inline primop - - - - - 8 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - libraries/base/GHC/IORef.hs - + libraries/base/tests/AtomicSwapIORef.hs - + libraries/base/tests/AtomicSwapIORef.stdout - libraries/base/tests/all.T - rts/include/Cmm.h Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -2604,6 +2604,12 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp has_side_effects = True code_size = { primOpCodeSizeForeignCall } -- for the write barrier +primop AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp + MutVar# s v -> v -> State# s -> (# State# s, v #) + {Atomically exchange the value of a 'MutVar#'.} + with + has_side_effects = True + -- Note [Why not an unboxed tuple in atomicModifyMutVar2#?] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Looking at the type of atomicModifyMutVar2#, one might wonder why ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -297,16 +297,12 @@ emitPrimOp cfg primop = -- MutVar's value. emitPrimCall [] (MO_AtomicWrite (wordWidth platform) MemOrderRelease) [ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ] + emitDirtyMutVar mutv (CmmReg old_val) - platform <- getPlatform - mkdirtyMutVarCCall <- getCode $! emitCCall - [{-no results-}] - (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - [(baseExpr platform, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] - emit =<< mkCmmIfThen - (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) - (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv)) - mkdirtyMutVarCCall + AtomicSwapMutVarOp -> \[mutv, val] -> opIntoRegs $ \[res] -> do + let dst = cmmOffsetW platform mutv (fixedHdrSizeW profile) + emitPrimCall [res] (MO_Xchg (wordWidth platform)) [dst, val] + emitDirtyMutVar mutv (CmmReg (CmmLocal res)) -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes @@ -3331,6 +3327,21 @@ doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz) +-- | Write barrier for @MUT_VAR@ modification. +emitDirtyMutVar :: CmmExpr -> CmmExpr -> FCode () +emitDirtyMutVar mutvar old_val = do + cfg <- getStgToCmmConfig + platform <- getPlatform + mkdirtyMutVarCCall <- getCode $! emitCCall + [{-no results-}] + (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + [(baseExpr platform, AddrHint), (mutvar, AddrHint), (old_val, AddrHint)] + + emit =<< mkCmmIfThen + (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) + (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutvar)) + mkdirtyMutVarCCall + --------------------------------------------------------------------------- -- Pushing to the update remembered set --------------------------------------------------------------------------- ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -801,6 +801,8 @@ genPrim prof bound ty op = case op of AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f] AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f] + AtomicSwapMutVarOp -> \[r] [mv,v] -> PrimInline $ mconcat + [ r |= mv .^ "val", mv .^ "val" |= v ] CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o) (mconcat [status |= zero_, r |= n, mv .^ "val" |= n]) (mconcat [status |= one_ , r |= mv .^ "val"]) ===================================== libraries/base/GHC/IORef.hs ===================================== @@ -127,12 +127,7 @@ atomicModifyIORef'_ ref f = do -- | Atomically replace the contents of an 'IORef', returning -- the old contents. atomicSwapIORef :: IORef a -> a -> IO a --- Bad implementation! This will be a primop shortly. -atomicSwapIORef (IORef (STRef ref)) new = IO $ \s -> - case atomicModifyMutVar2# ref (\_old -> Box new) s of - (# s', old, Box _new #) -> (# s', old #) - -data Box a = Box a +atomicSwapIORef (IORef (STRef ref)) new = IO (atomicSwapMutVar# ref new) -- | A strict version of 'Data.IORef.atomicModifyIORef'. This forces both the -- value stored in the 'IORef' and the value returned. ===================================== libraries/base/tests/AtomicSwapIORef.hs ===================================== @@ -0,0 +1,10 @@ +import Data.IORef +import GHC.IORef +import Data.Word + +main :: IO () +main = do + r <- newIORef 42 :: IO (IORef Int) + mapM (atomicSwapIORef r) [0..1000] >>= print + mapM (atomicSwapIORef r) [0..1000000] >>= print . sum . map (fromIntegral :: Int -> Integer) + readIORef r >>= print ===================================== libraries/base/tests/AtomicSwapIORef.stdout ===================================== @@ -0,0 +1,3 @@ +[42,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999] +499999501000 +1000000 ===================================== libraries/base/tests/all.T ===================================== @@ -298,3 +298,4 @@ test('listThreads', normal, compile_and_run, ['']) test('listThreads1', normal, compile_and_run, ['']) test('inits1tails1', normal, compile_and_run, ['']) test('CLC149', normal, compile, ['']) +test('AtomicSwapIORef', normal, compile_and_run, ['']) ===================================== rts/include/Cmm.h ===================================== @@ -193,8 +193,10 @@ #if SIZEOF_W == 4 #define cmpxchgW cmpxchg32 +#define xchgW xchg32 #elif SIZEOF_W == 8 #define cmpxchgW cmpxchg64 +#define xchgW xchg64 #endif /* ----------------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e2df4c9ac59a10080bd6e029e83a355ecd01c8b...6b29154de6b63597553c5b69b9974c8838a7a80a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e2df4c9ac59a10080bd6e029e83a355ecd01c8b...6b29154de6b63597553c5b69b9974c8838a7a80a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 22:40:32 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 09 May 2023 18:40:32 -0400 Subject: [Git][ghc/ghc][master] JS: add GHC.JS.Optimizer, remove RTS.Printer, add Linker.Opt Message-ID: <645acbe0c98ff_38ffdad6fba1f41388154@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 64064cfe by doyougnu at 2023-05-09T18:40:01-04:00 JS: add GHC.JS.Optimizer, remove RTS.Printer, add Linker.Opt This MR changes some simple optimizations and is a first step in re-architecting the JS backend pipeline to add the optimizer. In particular it: - removes simple peep hole optimizations from `GHC.StgToJS.Printer` and removes that module - adds module `GHC.JS.Optimizer` - defines the same peep hole opts that were removed only now they are `Syntax -> Syntax` transformations rather than `Syntax -> JS code` optimizations - hooks the optimizer into code gen - adds FuncStat and ForStat constructors to the backend. Working Ticket: - #22736 Related MRs: - MR !10142 - MR !10000 ------------------------- Metric Decrease: CoOpt_Read ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T12707 T13253 T13253-spj T15164 T17516 T18140 T18282 T18698a T18698b T18923 T1969 T19695 T20049 T3064 T5321FD T5321Fun T783 T9198 T9233 T9630 ------------------------- - - - - - 18 changed files: - compiler/GHC/JS/Make.hs - + compiler/GHC/JS/Optimizer.hs - compiler/GHC/JS/Ppr.hs - compiler/GHC/JS/Syntax.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/JS/Unsat/Syntax.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Printer.hs → compiler/GHC/StgToJS/Linker/Opt.hs - compiler/GHC/StgToJS/Object.hs - compiler/GHC/StgToJS/Rts/Rts.hs - compiler/ghc.cabal.in - + testsuite/tests/javascript/opt/all.T - + testsuite/tests/javascript/opt/deadCodeElim.hs - + testsuite/tests/javascript/opt/deadCodeElim.stdout - testsuite/tests/linters/notes.stdout Changes: ===================================== compiler/GHC/JS/Make.hs ===================================== @@ -83,7 +83,7 @@ module GHC.JS.Make -- $intro_funcs , var , jString - , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally + , jLam, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally -- * Combinators -- $combinators , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) @@ -253,7 +253,7 @@ jLam f = ValExpr . UnsatVal . IS $ do -- of the enclosed expression. The result is a block statement. -- Usage: -- --- @jVar $ \x y -> mconcat [jVar x ||= one_, jVar y ||= two_, jVar x + jVar y]@ +-- @jVar $ \x y -> mconcat [x ||= one_, y ||= two_, x + y]@ jVar :: ToSat a => a -> JStat jVar f = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] @@ -262,6 +262,9 @@ jVar f = UnsatBlock . IS $ do addDecls x = x return $ addDecls block +jFunction :: Ident -> [Ident] -> JStat -> JStat +jFunction name args body = FuncStat name args body + -- | Create a 'for in' statement. -- Usage: -- @@ -279,6 +282,23 @@ jForEachIn e f = UnsatBlock . IS $ do let i = head is return $ decl i `mappend` ForInStat True i e block +-- | Create a 'for' statement given a function for initialization, a predicate +-- to step to, a step and a body +-- Usage: +-- +-- @ jFor (|= zero_) (.<. Int 65536) preIncrS +-- (\j -> ...something with the counter j...)@ +-- +jFor :: (JExpr -> JStat) + -> (JExpr -> JExpr) + -> (JExpr -> JStat) + -> (JExpr -> JStat) + -> JStat +jFor init pred step body = jVar $ \i -> ForStat (init i) (pred i) (step i) (body i) + +jForNoDecl :: Ident -> JExpr -> JExpr -> JStat -> JStat -> JStat +jForNoDecl i initial p step body = ForStat (toJExpr i |= initial) p step body + -- | As with "jForIn" but creating a \"for each in\" statement. jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat jTryCatchFinally s f s2 = UnsatBlock . IS $ do @@ -294,13 +314,6 @@ var = ValExpr . JVar . TxtI jString :: FastString -> JExpr jString = toJExpr --- | Create a 'for' statement -jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat -jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b'] - where b' = case toStat b of - BlockStat xs -> BlockStat $ xs ++ [after] - x -> BlockStat [x,after] - -- | construct a js declaration with the given identifier decl :: Ident -> JStat decl i = DeclStat i Nothing ===================================== compiler/GHC/JS/Optimizer.hs ===================================== @@ -0,0 +1,271 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Optimizer +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Optimizer is a shallow embedding of a peephole optimizer. That is, +-- this module defines transformations over the JavaScript IR in +-- 'GHC.JS.Syntax', transforming the IR forms from inefficient, or +-- non-idiomatic, JavaScript to more efficient and idiomatic JavaScript. The +-- optimizer is written in continuation passing style so optimizations +-- compose. +-- +-- * Architecture of the optimizer +-- +-- The design is that each optimization pattern matches on the head of a +-- block by pattern matching onto the head of the stream of nodes in the +-- JavaScript IR. If an optimization gets a successful match then it performs +-- whatever rewrite is necessary and then calls the 'loop' continuation. This +-- ensures that the result of the optimization is subject to the same +-- optimization, /and/ the rest of the optimizations. If there is no match +-- then the optimization should call the 'next' continuation to pass the +-- stream to the next optimization in the optimization chain. We then define +-- the last "optimization" to be @tailLoop@ which selects the next block of +-- code to optimize and begin the optimization pipeline again. +----------------------------------------------------------------------------- +module GHC.JS.Optimizer + ( jsOptimize + ) where + + +import Prelude + +import GHC.JS.Syntax + +import Control.Arrow + +{- +Note [ Unsafe JavaScript Optimizations ] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of optimizations that the JavaScript Backend performs that +are not sound with respect to arbritrary JavaScript. We still perform these +optimizations because we are not optimizing arbritrary javascript and under the +assumption that the JavaScript backend will not generate code that violates the +soundness of the optimizer. For example, the @deadCodeElim@ optimization removes +all statements that occur after a 'return' in JavaScript, however this is not +always sound because of hoisting, consider this program: + + function foo() { + var x = 2; + bar(); + return x; + + function bar() { + x = 10; + }} + + which is transformed to: + + function foo() { + var x = 2; + bar(); + return x; + }} + +The optimized form is clearly a program that goes wrong because `bar()` is no +longer defined. But the JavaScript backend will never generate this code, so as +long as that assumption holds we are safe to perform optimizations that would +normally be unsafe. +-} + + +-------------------------------------------------------------------------------- +-- Top level Driver +-------------------------------------------------------------------------------- +jsOptimize :: JStat -> JStat +jsOptimize = go + where + p_opt = jsOptimize + opt = jsOptimize' + e_opt = jExprOptimize + -- base case + go (BlockStat xs) = BlockStat (opt xs) + -- recursive cases + go (ForStat i p s body) = ForStat (go i) (e_opt p) (go s) (p_opt body) + go (ForInStat b i p body) = ForInStat b i p (p_opt body) + go (WhileStat b c body) = WhileStat b (e_opt c) (p_opt body) + go (SwitchStat s ps body) = SwitchStat s (fmap (second go) ps) (p_opt body) + go (FuncStat i args body) = FuncStat i args (p_opt body) + go (IfStat c t e) = IfStat (e_opt c) (p_opt t) (p_opt e) + go (TryStat ths i c f) = TryStat (p_opt ths) i (p_opt c) (p_opt f) + go (LabelStat lbl s) = LabelStat lbl (p_opt s) + -- special case: drive the optimizer into expressions + go (AssignStat id op rhs) = AssignStat (e_opt id) op (e_opt rhs) + go (DeclStat i (Just e)) = DeclStat i (Just $ e_opt e) + go (ReturnStat e) = ReturnStat (e_opt e) + go (UOpStat op e) = UOpStat op (e_opt e) + go (ApplStat f args) = ApplStat (e_opt f) (e_opt <$> args) + -- all else is terminal, we match on these to force a warning in the event + -- another constructor is added + go x at BreakStat{} = x + go x at ContinueStat{} = x + go x at DeclStat{} = x -- match on the nothing case + +jsOptimize' :: [JStat] -> [JStat] +jsOptimize' = runBlockOpt opts . single_pass_opts + where + opts :: BlockOpt + opts = safe_opts + <> unsafe_opts + <> tailLoop -- tailloop must be last, see module description + + unsafe_opts :: BlockOpt + unsafe_opts = mconcat [ deadCodeElim ] + + safe_opts :: BlockOpt + safe_opts = mconcat [ declareAssign, combineOps ] + + single_pass_opts :: BlockTrans + single_pass_opts = runBlockTrans sp_opts + + sp_opts = [flattenBlocks] + +-- | recur over a @JExpr@ and optimize the @JVal at s +jExprOptimize :: JExpr -> JExpr +-- the base case +jExprOptimize (ValExpr val) = ValExpr (jValOptimize val) +-- recursive cases +jExprOptimize (SelExpr obj field) = SelExpr (jExprOptimize obj) field +jExprOptimize (IdxExpr obj ix) = IdxExpr (jExprOptimize obj) (jExprOptimize ix) +jExprOptimize (UOpExpr op exp) = UOpExpr op (jExprOptimize exp) +jExprOptimize (IfExpr c t e) = IfExpr c (jExprOptimize t) (jExprOptimize e) +jExprOptimize (ApplExpr f args ) = ApplExpr (jExprOptimize f) (jExprOptimize <$> args) +jExprOptimize (InfixExpr op l r) = InfixExpr op (jExprOptimize l) (jExprOptimize r) + +-- | drive optimizations to anonymous functions and over expressions +jValOptimize :: JVal -> JVal +-- base case +jValOptimize (JFunc args body) = JFunc args (jsOptimize body) +-- recursive cases +jValOptimize (JList exprs) = JList (jExprOptimize <$> exprs) +jValOptimize (JHash hash) = JHash (jExprOptimize <$> hash) +-- all else is terminal +jValOptimize x at JVar{} = x +jValOptimize x at JDouble{} = x +jValOptimize x at JInt{} = x +jValOptimize x at JStr{} = x +jValOptimize x at JRegEx{} = x + +-- | A block transformation is a function from a stream of syntax to another +-- stream +type BlockTrans = [JStat] -> [JStat] + +-- | A BlockOpt is a function that alters the stream, and a continuation that +-- represents the rest of the stream. The first @BlockTrans@ represents +-- restarting the optimizer after a change has happened. The second @BlockTrans@ +-- represents the rest of the continuation stream. +newtype BlockOpt = BlockOpt (BlockTrans -> BlockTrans -> BlockTrans) + +-- | To merge two BlockOpt we first run the left-hand side optimization and +-- capture the right-hand side in the continuation +instance Semigroup BlockOpt where + BlockOpt opt0 <> BlockOpt opt1 = BlockOpt + $ \loop next -> opt0 loop (opt1 loop next) + +instance Monoid BlockOpt where + -- don't loop, just finalize + mempty = BlockOpt $ \_loop next -> next + +-- | loop until a fixpoint is reached +runBlockOpt :: BlockOpt -> [JStat] -> [JStat] +runBlockOpt (BlockOpt opt) xs = recur xs + where recur = opt recur id + +runBlockTrans :: [BlockTrans] -> [JStat] -> [JStat] +runBlockTrans opts = foldl (.) id opts + +-- | Perform all the optimizations on the tail of a block. +tailLoop :: BlockOpt +tailLoop = BlockOpt $ \loop next -> \case + [] -> next [] + -- this call to jsOptimize is required or else the optimizer will not + -- properly recur down JStat. See the 'deadCodeElim' test for examples which + -- were failing before this change + (x:xs) -> next (jsOptimize x : loop xs) + +-------------------------------------------------------------------------------- +-- Single Slot Optimizations +-------------------------------------------------------------------------------- + +{- | + Catch modify and assign operators: + case 1: + i = i + 1; ==> ++i; + case 2: + i = i - 1; ==> --i; + case 3: + i = i + n; ==> i += n; + case 4: + i = i - n; ==> i -= n; +-} +combineOps :: BlockOpt +combineOps = BlockOpt $ \loop next -> + \case + -- find a op pattern, and rerun the optimizer on its result unless there is + -- nothing to optimize, in which case call the next optimization + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op (ValExpr (JVar i')) e)) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- commutative cases + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op e (ValExpr (JVar i')))) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- general case, we had nothing to optimize in this case so call the next + -- optimization + xs -> next xs + + +-------------------------------------------------------------------------------- +-- Dual Slot Optimizations +-------------------------------------------------------------------------------- +-- | Catch 'var i; i = q;' ==> 'var i = q;' +declareAssign :: BlockOpt +declareAssign = BlockOpt $ + \loop next -> \case + ( (DeclStat i Nothing) + : (AssignStat (ValExpr (JVar i')) AssignOp v) + : xs + ) | i == i' -> loop (DeclStat i (Just v) : xs) + xs -> next xs + +-- | Eliminate all code after a return statement. This is a special case +-- optimization that doesn't need to loop. See Note [Unsafe JavaScript +-- optimizations] +deadCodeElim :: BlockOpt +deadCodeElim = BlockOpt $ + \_loop next -> \case + (x at ReturnStat{}:_) -> next [x] + xs -> next xs + +-- | remove nested blocks +flattenBlocks :: BlockTrans +flattenBlocks (BlockStat y : ys) = flattenBlocks y ++ flattenBlocks ys +flattenBlocks (x:xs) = x : flattenBlocks xs +flattenBlocks [] = [] ===================================== compiler/GHC/JS/Ppr.hs ===================================== @@ -10,10 +10,46 @@ -- For Outputable instances for JS syntax {-# OPTIONS_GHC -Wno-orphans #-} --- | Pretty-printing JavaScript +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Ppr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Ppr defines the code generation facilities for the JavaScript +-- backend. That is, this module exports a function from the JS backend IR +-- to JavaScript compliant concrete syntax that can readily be executed by +-- nodejs or called in a browser. +-- +-- * Design +-- +-- This module follows the architecture and style of the other backends in +-- GHC: it intances Outputable for the relevant types, creates a class that +-- describes a morphism from the IR domain to JavaScript concrete Syntax and +-- then generates that syntax on a case by case basis. +-- +-- * How to use +-- +-- The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record. +-- Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for +-- specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a +-- custom renderer ensures all @Ident@ generated by the linker optimization +-- pass are prefixed differently than the default. Use @renderJS@ to +-- generate JavaScript concrete syntax in the general case, suitable for +-- human consumption. +----------------------------------------------------------------------------- + module GHC.JS.Ppr ( renderJs - , renderJs' , renderPrefixJs , renderPrefixJs' , JsToDoc(..) @@ -21,9 +57,10 @@ module GHC.JS.Ppr , RenderJs(..) , jsToDoc , pprStringLit - , flattenBlocks , braceNest , hangBrace + , interSemi + , addSemi ) where @@ -49,9 +86,9 @@ instance Outputable JExpr where instance Outputable JVal where ppr = docToSDoc . renderJs - -($$$) :: Doc -> Doc -> Doc -x $$$ y = nest 2 $ x $+$ y +-------------------------------------------------------------------------------- +-- Top level API +-------------------------------------------------------------------------------- -- | Render a syntax tree as a pretty-printable document -- (simply showing the resultant doc produces a nice, @@ -84,26 +121,17 @@ renderPrefixJs = renderPrefixJs' defaultRenderJs renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc renderPrefixJs' r = jsToDocR r -braceNest :: Doc -> Doc -braceNest x = char '{' <+> nest 2 x $$ char '}' - --- | Hang with braces: --- --- hdr { --- body --- } -hangBrace :: Doc -> Doc -> Doc -hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] +-------------------------------------------------------------------------------- +-- Code Generator +-------------------------------------------------------------------------------- class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc -instance JsToDoc JStat where jsToDocR r = renderJsS r r -instance JsToDoc JExpr where jsToDocR r = renderJsE r r -instance JsToDoc JVal where jsToDocR r = renderJsV r r -instance JsToDoc Ident where jsToDocR r = renderJsI r r -instance JsToDoc [JExpr] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) -instance JsToDoc [JStat] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc JStat where jsToDocR r = renderJsS r r +instance JsToDoc JExpr where jsToDocR r = renderJsE r r +instance JsToDoc JVal where jsToDocR r = renderJsV r r +instance JsToDoc Ident where jsToDocR r = renderJsI r r +instance JsToDoc [JExpr] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc [JStat] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r) defRenderJsS :: RenderJs -> JStat -> Doc defRenderJsS r = \case @@ -120,12 +148,16 @@ defRenderJsS r = \case ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s where - printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss + printBS (BlockStat ss) = vcat $ interSemi $ map (jsToDocR r) ss printBS x = jsToDocR r x - interSemi [x] = [jsToDocR r x] - interSemi [] = [] - interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs + ForStat init p s1 sb -> hangBrace (text "for" <> forCond) (jsToDocR r sb) + where + forCond = parens $ hcat $ interSemi + [ jsToDocR r init + , jsToDocR r p + , parens (jsToDocR r s1) + ] ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b) where txt | each = "for each" | otherwise = "for" @@ -134,12 +166,15 @@ defRenderJsS r = \case cases = vcat l' ReturnStat e -> text "return" <+> jsToDocR r e ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es) + FuncStat i is b -> hangBrace (text "function" <+> jsToDocR r i + <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) + (jsToDocR r b) TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally where mbCatch | s1 == BlockStat [] = PP.empty | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1) mbFinally | s2 == BlockStat [] = PP.empty | otherwise = hangBrace (text "finally") (jsToDocR r s2) - AssignStat i x -> case x of + AssignStat i op x -> case x of -- special treatment for functions, otherwise there is too much left padding -- (more than the length of the expression assigned to). E.g. -- @@ -148,19 +183,13 @@ defRenderJsS r = \case -- ... -- }); -- - ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] - _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x + ValExpr (JFunc is b) -> sep [jsToDocR r i <+> ftext (aOpText op) <+> text " function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] + _ -> jsToDocR r i <+> ftext (aOpText op) <+> jsToDocR r x UOpStat op x | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x | isPre op -> ftext (uOpText op) <> optParens r x | otherwise -> optParens r x <> ftext (uOpText op) - BlockStat xs -> jsToDocR r (flattenBlocks xs) - -flattenBlocks :: [JStat] -> [JStat] -flattenBlocks = \case - BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys - y:ys -> y : flattenBlocks ys - [] -> [] + BlockStat xs -> jsToDocR r xs optParens :: RenderJs -> JExpr -> Doc optParens r x = case x of @@ -204,33 +233,12 @@ defRenderJsV r = \case defRenderJsI :: RenderJs -> Ident -> Doc defRenderJsI _ (TxtI t) = ftext t +aOpText :: AOp -> FastString +aOpText = \case + AssignOp -> "=" + AddAssignOp -> "+=" + SubAssignOp -> "-=" -pprStringLit :: FastString -> Doc -pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] - -encodeJson :: FastString -> Doc -encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) - -encodeJsonChar :: Char -> Doc -encodeJsonChar = \case - '/' -> text "\\/" - '\b' -> text "\\b" - '\f' -> text "\\f" - '\n' -> text "\\n" - '\r' -> text "\\r" - '\t' -> text "\\t" - '"' -> text "\\\"" - '\\' -> text "\\\\" - c - | not (isControl c) && ord c <= 127 -> char c - | ord c <= 0xff -> hexxs "\\x" 2 (ord c) - | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) - | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair - in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> - hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) - where hexxs prefix pad cp = - let h = showHex cp "" - in text (prefix ++ replicate (pad - length h) '0' ++ h) uOpText :: UOp -> FastString uOpText = \case @@ -289,3 +297,56 @@ isAlphaOp = \case YieldOp -> True VoidOp -> True _ -> False + +pprStringLit :: FastString -> Doc +pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +encodeJson :: FastString -> Doc +encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) + +encodeJsonChar :: Char -> Doc +encodeJsonChar = \case + '/' -> text "\\/" + '\b' -> text "\\b" + '\f' -> text "\\f" + '\n' -> text "\\n" + '\r' -> text "\\r" + '\t' -> text "\\t" + '"' -> text "\\\"" + '\\' -> text "\\\\" + c + | not (isControl c) && ord c <= 127 -> char c + | ord c <= 0xff -> hexxs "\\x" 2 (ord c) + | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) + | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair + in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> + hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) + where hexxs prefix pad cp = + let h = showHex cp "" + in text (prefix ++ replicate (pad - length h) '0' ++ h) + +braceNest :: Doc -> Doc +braceNest x = char '{' <+> nest 2 x $$ char '}' + +interSemi :: [Doc] -> [Doc] +interSemi [] = [] +interSemi [s] = [s] +interSemi (x:xs) = x <> text ";" : interSemi xs + +addSemi :: Doc -> Doc +addSemi x = x <> text ";" + +-- | Hang with braces: +-- +-- hdr { +-- body +-- } +hangBrace :: Doc -> Doc -> Doc +hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] + +($$$) :: Doc -> Doc -> Doc +x $$$ y = nest 2 $ x $+$ y ===================================== compiler/GHC/JS/Syntax.hs ===================================== @@ -58,6 +58,7 @@ module GHC.JS.Syntax , JVal(..) , Op(..) , UOp(..) + , AOp(..) , Ident(..) , JLabel -- * pattern synonyms over JS operators @@ -110,20 +111,22 @@ import GHC.Generics -- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) -- for details data JStat - = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] - | ReturnStat JExpr -- ^ Return - | IfStat JExpr JStat JStat -- ^ If + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForStat JStat JExpr JStat JStat -- ^ For | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch | TryStat JStat Ident JStat JStat -- ^ Try - | BlockStat [JStat] -- ^ Blocks - | ApplStat JExpr [JExpr] -- ^ Application - | UOpStat UOp JExpr -- ^ Unary operators - | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ - | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic - | BreakStat (Maybe JLabel) -- ^ Break - | ContinueStat (Maybe JLabel) -- ^ Continue + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat UOp JExpr -- ^ Unary operators + | AssignStat JExpr AOp JExpr -- ^ Binding form: @ @ + | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JLabel) -- ^ Break + | ContinueStat (Maybe JLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition deriving (Eq, Typeable, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of @@ -146,9 +149,9 @@ appendJStat mx my = case (mx,my) of (BlockStat [] , y ) -> y (x , BlockStat []) -> x (BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys - (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] - (xs , BlockStat ys) -> BlockStat $! xs : ys - (xs , ys ) -> BlockStat [xs,ys] + (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $! xs : ys + (xs , ys ) -> BlockStat [xs,ys] -------------------------------------------------------------------------------- @@ -156,13 +159,13 @@ appendJStat mx my = case (mx,my) of -------------------------------------------------------------------------------- -- | JavaScript Expressions data JExpr - = ValExpr JVal -- ^ All values are trivially expressions - | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' - | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' - | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms - | UOpExpr UOp JExpr -- ^ Unary Expressions + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms + | UOpExpr UOp JExpr -- ^ Unary Expressions | IfExpr JExpr JExpr JExpr -- ^ If-expression - | ApplExpr JExpr [JExpr] -- ^ Application + | ApplExpr JExpr [JExpr] -- ^ Application deriving (Eq, Typeable, Generic) -- * Useful pattern synonyms to ease programming with the deeply embedded JS @@ -321,6 +324,15 @@ data UOp instance NFData UOp +-- | JS Unary Operators +data AOp + = AssignOp -- ^ Vanilla Assignment: = + | AddAssignOp -- ^ Addition Assignment: += + | SubAssignOp -- ^ Subtraction Assignment: -= + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData AOp + -- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' -- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on -- Sane-ness @@ -345,10 +357,12 @@ instance Show SaneDouble where -------------------------------------------------------------------------------- jassignAllEqual :: [JExpr] -> [JExpr] -> JStat -jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" AssignStat xs ys) +jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" go xs ys) + where go l r = AssignStat l AssignOp r jassignAll :: [JExpr] -> [JExpr] -> JStat -jassignAll xs ys = mconcat (zipWith AssignStat xs ys) +jassignAll xs ys = mconcat $ zipWith go xs ys + where go l r = AssignStat l AssignOp r jvar :: FastString -> JExpr jvar = ValExpr . JVar . TxtI ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -47,6 +47,7 @@ identsS = \case Sat.ReturnStat e -> identsE e Sat.IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 Sat.WhileStat _ e s -> identsE e ++ identsS s + Sat.ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body Sat.ForInStat _ i e s -> [i] ++ identsE e ++ identsS s Sat.SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s where traverseCase (e,s) = identsE e ++ identsS s @@ -54,10 +55,11 @@ identsS = \case Sat.BlockStat xs -> concatMap identsS xs Sat.ApplStat e es -> identsE e ++ concatMap identsE es Sat.UOpStat _op e -> identsE e - Sat.AssignStat e1 e2 -> identsE e1 ++ identsE e2 + Sat.AssignStat e1 _op e2 -> identsE e1 ++ identsE e2 Sat.LabelStat _l s -> identsS s Sat.BreakStat{} -> [] Sat.ContinueStat{} -> [] + Sat.FuncStat i args body -> [i] ++ args ++ identsS body {-# INLINE identsE #-} identsE :: Sat.JExpr -> [Ident] @@ -148,6 +150,8 @@ jmcompos ret app f' v = ReturnStat i -> ret ReturnStat `app` f i IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s' WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s + ForStat init p step body -> ret ForStat `app` f init `app` f p + `app` f step `app` f body ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l @@ -158,6 +162,7 @@ jmcompos ret app f' v = AssignStat e e' -> ret AssignStat `app` f e `app` f e' UnsatBlock _ -> ret v' ContinueStat l -> ret (ContinueStat l) + FuncStat i args body -> ret FuncStat `app` f i `app` mapM' f args `app` f body BreakStat l -> ret (BreakStat l) LabelStat l s -> ret (LabelStat l) `app` f s JMGExpr v' -> ret JMGExpr `app` case v' of @@ -217,7 +222,6 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) -------------------------------------------------------------------------------- -- Translation -- --- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- satJStat :: JStat -> Sat.JStat satJStat = witness . proof @@ -229,6 +233,9 @@ satJStat = witness . proof witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) + witness (ForStat init p step body) = Sat.ForStat + (witness init) (satJExpr p) + (witness step) (witness body) witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i (satJExpr iter) (witness body) @@ -240,12 +247,13 @@ satJStat = witness . proof witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) + witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) Sat.AssignOp (satJExpr rhs) witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) witness (BreakStat Nothing) = Sat.BreakStat Nothing witness (BreakStat (Just l)) = Sat.BreakStat $! Just l witness (ContinueStat Nothing) = Sat.ContinueStat Nothing witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l + witness (FuncStat i args body) = Sat.FuncStat i args (witness body) witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" ===================================== compiler/GHC/JS/Unsat/Syntax.hs ===================================== @@ -146,6 +146,7 @@ data JStat | ReturnStat JExpr -- ^ Return | IfStat JExpr JStat JStat -- ^ If | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForStat JStat JExpr JStat JStat -- ^ For | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch | TryStat JStat Ident JStat JStat -- ^ Try @@ -157,6 +158,7 @@ data JStat | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic | BreakStat (Maybe JsLabel) -- ^ Break | ContinueStat (Maybe JsLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition deriving (Eq, Typeable, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of ===================================== compiler/GHC/StgToJS/Apply.hs ===================================== @@ -408,17 +408,11 @@ mkApplyArr = mconcat [ TxtI "h$apply" ||= toJExpr (JList []) , TxtI "h$paps" ||= toJExpr (JList []) , ApplStat (var "h$initStatic" .^ "push") - [ ValExpr $ JFunc [] $ jVar \i -> mconcat - [ i |= zero_ - , WhileStat False (i .<. Int 65536) $ mconcat - [ var "h$apply" .! i |= var "h$ap_gen" - , preIncrS i - ] - , i |= zero_ - , WhileStat False (i .<. Int 128) $ mconcat - [ var "h$paps" .! i |= var "h$pap_gen" - , preIncrS i - ] + [ ValExpr $ JFunc [] $ mconcat + [ jFor (|= zero_) (.<. Int 65536) preIncrS + (\j -> var "h$apply" .! j |= var "h$ap_gen") + , jFor (|= zero_) (.<. Int 128) preIncrS + (\j -> var "h$paps" .! j |= var "h$pap_gen") , mconcat (map assignSpec applySpec) , mconcat (map assignPap specPap) ] ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -16,6 +16,7 @@ import GHC.JS.Ppr import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Arg import GHC.StgToJS.Sinker @@ -133,10 +134,10 @@ genUnits m ss spt_entries foreign_stubs = do glbl <- State.gets gsGlobal staticInit <- initStaticPtrs spt_entries - let stat = ( -- O.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m 1) - $ mconcat (reverse glbl) <> staticInit) + let stat = ( jsOptimize + . satJStat + . jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] let oi = ObjUnit { oiSymbols = syms @@ -208,7 +209,9 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsOptimize + . satJStat + $ jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -245,10 +248,10 @@ genUnits m ss spt_entries foreign_stubs = do let allDeps = collectIds unf decl topDeps = collectTopIds decl required = hasExport decl - stat = -- Opt.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m n) - $ mconcat (reverse extraTl) <> tl + stat = jsOptimize + . satJStat + . jsSaturate (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps let oi = ObjUnit { oiSymbols = syms @@ -308,15 +311,15 @@ genSetConInfo i d l {- srt -} = do (fixedLayout $ map uTypeVt fields) (CICon $ dataConTag d) sr - return (ei ||= mkDataEntry) + return (mkDataEntry ei) where -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug? fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing) (dataConRepArgTys d) -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d) -mkDataEntry :: JExpr -mkDataEntry = ValExpr $ JFunc [] returnStack +mkDataEntry :: Ident -> JStat +mkDataEntry i = FuncStat i [] returnStack genToplevelRhs :: Id -> CgStgRhs -> G JStat -- general cases: ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -240,7 +240,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = body <- genBody ctx R1 args body typ ei@(TxtI eii) <- identForEntryId i sr <- genStaticRefsRhs rhs - let f = JFunc [] (bh <> lvs <> body) + let f = (bh <> lvs <> body) emitClosureInfo $ ClosureInfo ei (CIRegs 0 $ concatMap idVt args) @@ -249,7 +249,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = map (stackSlotType . fst) (ctxLneFrameVars ctx)) CIStackFrame sr - emitToplevel (ei ||= toJExpr f) + emitToplevel (jFunction ei [] f) genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do let payloadSize = ctxLneFrameSize ctx ei@(TxtI _eii) <- identForEntryId i @@ -258,8 +258,7 @@ genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do p <- popLneFrame True payloadSize ctx args' <- concatMapM genArg args ac <- allocCon ii con cc args' - emitToplevel (ei ||= toJExpr (JFunc [] - (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack]))) + emitToplevel (jFunction ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])) -- | Generate the entry function for a local closure genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () @@ -283,7 +282,7 @@ genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) = (fixedLayout $ map (uTypeVt . idType) live) et sr - emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + emitToplevel (jFunction ei [] (mconcat [ll, llv, upd, setcc, body])) where entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) @@ -630,7 +629,7 @@ genRet ctx e at as l = freshIdent >>= f ++ if prof then [ObjV] else map stackSlotType lneVars) CIStackFrame sr - emitToplevel $ r ||= toJExpr (JFunc [] fun') + emitToplevel $ jFunction r [] fun' return (pushLne <> saveCCS <> pushRet) fst3 ~(x,_,_) = x ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -30,6 +30,7 @@ import Prelude import GHC.Platform.Host (hostPlatformArchOS) import GHC.JS.Make +import GHC.JS.Optimizer import GHC.JS.Unsat.Syntax import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform @@ -43,11 +44,11 @@ import GHC.Linker.Static.Utils (exeFileName) import GHC.StgToJS.Linker.Types import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Linker.Opt import GHC.StgToJS.Rts.Rts import GHC.StgToJS.Object import GHC.StgToJS.Types hiding (LinkableUnit) import GHC.StgToJS.Symbols -import GHC.StgToJS.Printer import GHC.StgToJS.Arg import GHC.StgToJS.Closure @@ -332,7 +333,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsOptimize $ satJStat meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Printer.hs → compiler/GHC/StgToJS/Linker/Opt.hs ===================================== @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | --- Module : GHC.StgToJS.Printer +-- Module : GHC.StgToJS.Linker.Opt -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE) -- @@ -13,15 +13,14 @@ -- Sylvain Henry -- Stability : experimental -- --- Custom prettyprinter for JS AST uses the JS PPr module for most of --- the work +-- Optimization pass at link time +-- -- -- ----------------------------------------------------------------------------- -module GHC.StgToJS.Printer +module GHC.StgToJS.Linker.Opt ( pretty , ghcjsRenderJs - , prettyBlock ) where @@ -93,8 +92,7 @@ hexDoc v = text $ go v -- attempt to resugar some of the common constructs ghcjsRenderJsS :: RenderJs -> JStat -> Doc -ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) -ghcjsRenderJsS r s = renderJsS defaultRenderJs r s +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s -- don't quote keys in our object literals, so closure compiler works ghcjsRenderJsV :: RenderJs -> JVal -> Doc @@ -120,97 +118,3 @@ ghcjsRenderJsV r (JHash m) validOtherIdent c = isAlpha c || isDigit c ghcjsRenderJsV r v = renderJsV defaultRenderJs r v - -prettyBlock :: RenderJs -> [JStat] -> Doc -prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs) - --- recognize common patterns in a block and convert them to more idiomatic/concise javascript -prettyBlock' :: RenderJs -> [JStat] -> [Doc] --- return/... -prettyBlock' r ( x@(ReturnStat _) - : xs - ) - | not (null xs) - = prettyBlock' r [x] --- declare/assign -prettyBlock' r ( (DeclStat i Nothing) - : (AssignStat (ValExpr (JVar i')) v) - : xs - ) - | i == i' - = prettyBlock' r (DeclStat i (Just v) : xs) - --- resugar for loops with/without var declaration -prettyBlock' r ( (DeclStat i (Just v0)) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs - --- global function (does not preserve semantics but works for GHCJS) -prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b)))) - : xs - ) - = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) - (jsToDocR r b) - ) : prettyBlock' r xs --- modify/assign operators -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs - - -prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs -prettyBlock' _ [] = [] - --- build the for block -mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc -mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond) - (jsToDocR r $ BlockStat sb) - where - c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0 - | otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0 - forCond = parens $ hcat $ interSemi - [ c0 - , jsToDocR r p - , parens (jsToDocR r s1) - ] - --- check if a statement is suitable to be converted to something in the for(;;x) position -isForUpdStat :: JStat -> Bool -isForUpdStat UOpStat {} = True -isForUpdStat AssignStat {} = True -isForUpdStat ApplStat {} = True -isForUpdStat _ = False - -interSemi :: [Doc] -> [Doc] -interSemi [] = [PP.empty] -interSemi [s] = [s] -interSemi (x:xs) = x <> text ";" : interSemi xs - -addSemi :: Doc -> Doc -addSemi x = x <> text ";" ===================================== compiler/GHC/StgToJS/Object.hs ===================================== @@ -408,31 +408,35 @@ instance Binary Sat.JStat where put_ bh (Sat.ReturnStat e) = putByte bh 2 >> put_ bh e put_ bh (Sat.IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 put_ bh (Sat.WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s - put_ bh (Sat.ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s - put_ bh (Sat.SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s - put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 - put_ bh (Sat.BlockStat xs) = putByte bh 8 >> put_ bh xs - put_ bh (Sat.ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es - put_ bh (Sat.UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e - put_ bh (Sat.AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 - put_ bh (Sat.LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s - put_ bh (Sat.BreakStat ml) = putByte bh 13 >> put_ bh ml - put_ bh (Sat.ContinueStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ForStat is c s bd) = putByte bh 5 >> put_ bh is >> put_ bh c >> put_ bh s >> put_ bh bd + put_ bh (Sat.ForInStat b i e s) = putByte bh 6 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (Sat.SwitchStat e ss s) = putByte bh 7 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 8 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (Sat.BlockStat xs) = putByte bh 9 >> put_ bh xs + put_ bh (Sat.ApplStat e es) = putByte bh 10 >> put_ bh e >> put_ bh es + put_ bh (Sat.UOpStat o e) = putByte bh 11 >> put_ bh o >> put_ bh e + put_ bh (Sat.AssignStat e1 op e2) = putByte bh 12 >> put_ bh e1 >> put_ bh op >> put_ bh e2 + put_ bh (Sat.LabelStat l s) = putByte bh 13 >> put_ bh l >> put_ bh s + put_ bh (Sat.BreakStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ContinueStat ml) = putByte bh 15 >> put_ bh ml + put_ bh (Sat.FuncStat i is b) = putByte bh 16 >> put_ bh i >> put_ bh is >> put_ bh b get bh = getByte bh >>= \case 1 -> Sat.DeclStat <$> get bh <*> get bh 2 -> Sat.ReturnStat <$> get bh 3 -> Sat.IfStat <$> get bh <*> get bh <*> get bh 4 -> Sat.WhileStat <$> get bh <*> get bh <*> get bh - 5 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh - 6 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh - 7 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh - 8 -> Sat.BlockStat <$> get bh - 9 -> Sat.ApplStat <$> get bh <*> get bh - 10 -> Sat.UOpStat <$> get bh <*> get bh - 11 -> Sat.AssignStat <$> get bh <*> get bh - 12 -> Sat.LabelStat <$> get bh <*> get bh - 13 -> Sat.BreakStat <$> get bh - 14 -> Sat.ContinueStat <$> get bh + 5 -> Sat.ForStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 7 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh + 8 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 9 -> Sat.BlockStat <$> get bh + 10 -> Sat.ApplStat <$> get bh <*> get bh + 11 -> Sat.UOpStat <$> get bh <*> get bh + 12 -> Sat.AssignStat <$> get bh <*> get bh <*> get bh + 13 -> Sat.LabelStat <$> get bh <*> get bh + 14 -> Sat.BreakStat <$> get bh + 15 -> Sat.ContinueStat <$> get bh + 16 -> Sat.FuncStat <$> get bh <*> get bh <*> get bh n -> error ("Binary get bh JStat: invalid tag: " ++ show n) @@ -541,6 +545,10 @@ instance Binary Sat.UOp where put_ bh = putEnum bh get bh = getEnum bh +instance Binary Sat.AOp where + put_ bh = putEnum bh + get bh = getEnum bh + -- 16 bit sizes should be enough... instance Binary CILayout where put_ bh CILayoutVariable = putByte bh 1 ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,16 +30,18 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Apply import GHC.StgToJS.Closure import GHC.StgToJS.Heap -import GHC.StgToJS.Printer import GHC.StgToJS.Profiling import GHC.StgToJS.Regs import GHC.StgToJS.Types import GHC.StgToJS.Stack +import GHC.StgToJS.Linker.Opt + import GHC.Data.FastString import GHC.Types.Unique.Map @@ -134,7 +136,7 @@ closureConstructors s = BlockStat | otherwise = mempty mkClosureCon :: Maybe Int -> JStat - mkClosureCon n0 = funName ||= toJExpr fun + mkClosureCon n0 = jFunction funName args funBod where n | Just n' <- n0 = n' | Nothing <- n0 = 0 @@ -142,7 +144,6 @@ closureConstructors s = BlockStat | Nothing <- n0 = TxtI $ mkFastString "h$c" -- args are: f x1 x2 .. xn [cc] args = TxtI "f" : addCCArg' (map varName [1..n]) - fun = JFunc args funBod -- x1 goes into closureField1. All the other args are bundled into an -- object in closureField2: { d1 = x2, d2 = x3, ... } -- @@ -157,12 +158,12 @@ closureConstructors s = BlockStat ] mkDataFill :: Int -> JStat - mkDataFill n = funName ||= toJExpr fun + mkDataFill n = jFunction funName (map TxtI ds) body where funName = TxtI $ dataName n ds = map dataFieldName [1..n] extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds - fun = JFunc (map TxtI ds) (checkD <> returnS extra_args) + body = (checkD <> returnS extra_args) -- | JS Payload to perform stack manipulation in the RTS stackManip :: JStat @@ -172,10 +173,10 @@ stackManip = mconcat (map mkPush [1..32]) <> mkPush :: Int -> JStat mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) as = map varName [1..n] - fun = JFunc as ((sp |= sp + toJExpr n) - <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) - [1..] as)) - in funName ||= toJExpr fun + body = ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + [1..] as)) + in jFunction funName as body -- partial pushes, based on bitmap, increases Sp by highest bit mkPpush :: Integer -> JStat @@ -185,11 +186,10 @@ stackManip = mconcat (map mkPush [1..32]) <> n = length bits h = last bits args = map varName [1..n] - fun = JFunc args $ - mconcat [ sp |= sp + toJExpr (h+1) - , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) - ] - in funName ||= toJExpr fun + body = mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) + ] + in jFunction funName args body bitsIdx :: Integer -> [Int] bitsIdx n | n < 0 = error "bitsIdx: negative" @@ -244,12 +244,12 @@ loadRegs :: JStat loadRegs = mconcat $ map mkLoad [1..32] where mkLoad :: Int -> JStat - mkLoad n = let args = map varName [1..n] - assign = zipWith (\a r -> toJExpr r |= toJExpr a) - args (reverse $ take n regsFromR1) - fname = TxtI $ mkFastString ("h$l" ++ show n) - fun = JFunc args (mconcat assign) - in fname ||= toJExpr fun + mkLoad n = let args = map varName [1..n] + body = mconcat $ + zipWith (\a r -> toJExpr r |= toJExpr a) + args (reverse $ take n regsFromR1) + fname = TxtI $ mkFastString ("h$l" ++ show n) + in jFunction fname args body -- | Assign registers R1 ... Rn in descending order, that is assign Rn first. -- This function uses the 'assignRegs'' array to construct functions which set @@ -314,11 +314,11 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . jsOptimize . satJStat . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty . jsOptimize . satJStat $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' rts :: StgToJSConfig -> JStat ===================================== compiler/ghc.cabal.in ===================================== @@ -532,6 +532,7 @@ Library GHC.IfaceToCore GHC.Iface.Type GHC.JS.Make + GHC.JS.Optimizer GHC.JS.Ppr GHC.JS.Syntax GHC.JS.Transform @@ -672,7 +673,6 @@ Library GHC.StgToJS.Object GHC.StgToJS.Prim GHC.StgToJS.Profiling - GHC.StgToJS.Printer GHC.StgToJS.Regs GHC.StgToJS.Rts.Types GHC.StgToJS.Rts.Rts @@ -686,6 +686,7 @@ Library GHC.StgToJS.Linker.Linker GHC.StgToJS.Linker.Types GHC.StgToJS.Linker.Utils + GHC.StgToJS.Linker.Opt GHC.Stg.Unarise GHC.SysTools GHC.SysTools.Ar ===================================== testsuite/tests/javascript/opt/all.T ===================================== @@ -0,0 +1,4 @@ +# These are JavaScript-specific tests for the JS backend optimizer +setTestOpts(when(not(js_arch()),skip)) + +test('deadCodeElim', normal, compile_and_run, ['-package ghc']) ===================================== testsuite/tests/javascript/opt/deadCodeElim.hs ===================================== @@ -0,0 +1,96 @@ + +import GHC.JS.Optimizer +import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax (Ident (..)) + +import GHC.Data.FastString + +double_return :: JStat +double_return = BlockStat [ ReturnStat (SatInt 0) + , ReturnStat (SatInt 1) + ] + +double_return_opt :: JStat +double_return_opt = (BlockStat [ReturnStat (SatInt 0)]) + +in_func :: JStat +in_func = AssignStat (jvar (fsLit "foo")) AssignOp (ValExpr (JFunc [] double_return)) + +in_func_opt :: JStat +in_func_opt = AssignStat (jvar (fsLit "foo")) AssignOp (ValExpr (JFunc [] double_return_opt)) + +nested_blocks :: JStat +nested_blocks = BlockStat [ double_return <> double_return + , double_return + ] <> double_return + +nested_blocks_opt :: JStat +nested_blocks_opt = double_return_opt + +global_func :: JStat +global_func = FuncStat (TxtI (fsLit "bar")) [] double_return + +global_func_opt :: JStat +global_func_opt = FuncStat (TxtI (fsLit "bar")) [] double_return_opt + +func_with_locals :: JStat +func_with_locals = AssignStat (jvar (fsLit "foo")) + AssignOp + (ValExpr (JFunc [] + (BlockStat [ AssignStat (jvar (fsLit "one")) AssignOp (SatInt 2) + , AssignStat (jvar (fsLit "two")) AssignOp (SatInt 3) + , ApplStat (jvar (fsLit "f")) [(SatInt 100)] + , ReturnStat (SatInt 0) + , ReturnStat (SatInt 1) + ]))) + +func_with_locals_opt :: JStat +func_with_locals_opt = AssignStat (jvar (fsLit "foo")) + AssignOp + (ValExpr (JFunc [] + (BlockStat [ AssignStat (jvar (fsLit "one")) AssignOp (SatInt 2) + , AssignStat (jvar (fsLit "two")) AssignOp (SatInt 3) + , ApplStat (jvar (fsLit "f")) [(SatInt 100)] + , ReturnStat (SatInt 0) + ]))) + +-- This one comes straight from MR10260 where we noticed the optimizer was not catching the redundant return +bignum_test :: JStat +bignum_test = DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + , ReturnStat (ApplExpr (jvar $ fsLit "h$rs") [])])) + +bignum_test_opt :: JStat +bignum_test_opt = + DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + ])) + +bignum_test_2 :: JStat +bignum_test_2 = BlockStat [FuncStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99") [] (BlockStat [DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + , ReturnStat (ApplExpr (jvar $ fsLit "h$rs") [])]))])] + +bignum_test_opt_2 :: JStat +bignum_test_opt_2 = BlockStat [FuncStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99") [] (BlockStat [DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + ]))])] + +main :: IO () +main = mapM_ print + [ jsOptimize double_return == double_return_opt + , jsOptimize in_func == in_func_opt + , jsOptimize nested_blocks == nested_blocks_opt + , jsOptimize global_func == global_func_opt + , jsOptimize func_with_locals == func_with_locals_opt + , jsOptimize bignum_test == bignum_test_opt + , jsOptimize bignum_test_2 == bignum_test_opt_2 + ] ===================================== testsuite/tests/javascript/opt/deadCodeElim.stdout ===================================== @@ -0,0 +1,7 @@ +True +True +True +True +True +True +True ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -7,7 +7,7 @@ ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] ref compiler/GHC/Core/Opt/Specialise.hs:1790:28: Note [Arity decrease] ref compiler/GHC/Core/TyCo/Rep.hs:1556:31: Note [What prevents a constraint from floating] ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Driver/Session.hs:3993:49: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Session.hs:4062:49: Note [Eta-reduction in -O0] ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] ref compiler/GHC/Hs/Expr.hs:1736:87: Note [Lifecycle of a splice] ref compiler/GHC/Hs/Expr.hs:1772:7: Note [Pending Splices] @@ -15,6 +15,7 @@ ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constr ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/JS/Optimizer.hs:206:7: Note [Unsafe JavaScript optimizations] ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] ref compiler/GHC/StgToCmm.hs:106:18: Note [codegen-split-init] ref compiler/GHC/StgToCmm.hs:109:18: Note [pipeline-split-init] @@ -25,14 +26,14 @@ ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:357:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:532:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:656:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:889:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] ref compiler/GHC/Tc/Module.hs:711:15: Note [Extra dependencies from .hs-boot files] ref compiler/GHC/Tc/Solver/Rewrite.hs:1008:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1120:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/TyCl.hs:1124:6: Note [Unification variables need fresh Names] ref compiler/GHC/Tc/Types.hs:692:33: Note [Extra dependencies from .hs-boot files] ref compiler/GHC/Tc/Types.hs:1423:47: Note [Care with plugin imports] ref compiler/GHC/Tc/Types/Constraint.hs:255:34: Note [NonCanonical Semantics] @@ -46,8 +47,8 @@ ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threa ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ref linters/lint-notes/Notes.hs:69:22: Note [...] ref testsuite/config/ghc:272:10: Note [WayFlags] -ref testsuite/driver/testlib.py:160:10: Note [Why is there no stage1 setup function?] -ref testsuite/driver/testlib.py:164:2: Note [Why is there no stage1 setup function?] +ref testsuite/driver/testlib.py:165:10: Note [Why is there no stage1 setup function?] +ref testsuite/driver/testlib.py:169:2: Note [Why is there no stage1 setup function?] ref testsuite/mk/boilerplate.mk:267:2: Note [WayFlags] ref testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs:30:27: Note [Extra TcS Untouchables] ref testsuite/tests/perf/should_run/all.T:8:6: Note [Solving from instances when interacting Dicts] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64064cfee57161bb42ef5c17bbe434185893ee5f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64064cfee57161bb42ef5c17bbe434185893ee5f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 22:40:53 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 09 May 2023 18:40:53 -0400 Subject: [Git][ghc/ghc][master] Add a regression test for #21050 Message-ID: <645acbf580692_38ffdad701e3c013914ba@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6738c01d by Krzysztof Gogolewski at 2023-05-09T18:40:38-04:00 Add a regression test for #21050 - - - - - 3 changed files: - + testsuite/tests/th/T21050.hs - + testsuite/tests/th/T21050.stderr - testsuite/tests/th/all.T Changes: ===================================== testsuite/tests/th/T21050.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell, ImpredicativeTypes #-} +module T21050 where + +import Language.Haskell.TH.Syntax + +data T = MkT (forall a. a) + +f x = [|| MkT $$(x) ||] + +g :: Code Q (forall a. a) -> Code Q T +g x = [|| MkT $$(x) ||] ===================================== testsuite/tests/th/T21050.stderr ===================================== @@ -0,0 +1,26 @@ + +T21050.hs:8:18: error: [GHC-25897] + • Couldn't match expected type ‘Code m a1’ with actual type ‘p’ + ‘p’ is a rigid type variable bound by + the inferred type of f :: Quote m => p -> Code m T + at T21050.hs:8:1-23 + • In the expression: x + In the Template Haskell splice $$(x) + In the first argument of ‘MkT’, namely ‘$$(x)’ + • Relevant bindings include + x :: p (bound at T21050.hs:8:3) + f :: p -> Code m T (bound at T21050.hs:8:1) + +T21050.hs:11:18: error: [GHC-91028] + • Couldn't match type ‘a’ with ‘forall a2. a2’ + Expected: Code Q a + Actual: Code Q (forall a. a) + Cannot equate type variable ‘a’ + with a type involving polytypes: forall a2. a2 + ‘a’ is a rigid type variable bound by + a type expected by the context: + forall a. a + at T21050.hs:11:15-19 + • In the expression: x + In the Template Haskell splice $$(x) + In the first argument of ‘MkT’, namely ‘$$(x)’ ===================================== testsuite/tests/th/all.T ===================================== @@ -564,3 +564,4 @@ test('TH_typed2', normal, compile_and_run, ['']) test('TH_typed3', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_typed4', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_typed5', normal, compile_and_run, ['']) +test('T21050', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6738c01d6175c5701e5c53e2ae6716d1103f7355 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6738c01d6175c5701e5c53e2ae6716d1103f7355 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 22:41:34 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 09 May 2023 18:41:34 -0400 Subject: [Git][ghc/ghc][master] nonmoving: Account for mutator allocations in bytes_allocated Message-ID: <645acc1ec2da5_38ffdad7a59b3c1396669@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b2cdb7da by Ben Gamari at 2023-05-09T18:41:14-04:00 nonmoving: Account for mutator allocations in bytes_allocated Previously we failed to account direct mutator allocations into the nonmoving heap against the mutator's allocation limit and `cap->total_allocated`. This only manifests during CAF evaluation (since we allocate the CAF's blackhole directly into the nonmoving heap). Fixes #23312. - - - - - 3 changed files: - rts/sm/NonMovingAllocate.c - rts/sm/Storage.c - rts/sm/Storage.h Changes: ===================================== rts/sm/NonMovingAllocate.c ===================================== @@ -253,5 +253,9 @@ void *nonmovingAllocateGC(Capability *cap, StgWord sz) GNUC_ATTR_HOT void *nonmovingAllocate(Capability *cap, StgWord sz) { + // Handle "bytes allocated" accounting in the same way we + // do in Storage.c:allocate. See #23312. + accountAllocation(cap, sz); + cap->total_allocated += sz; return nonmovingAllocate_(SM_LOCK, cap, sz); } ===================================== rts/sm/Storage.c ===================================== @@ -966,7 +966,7 @@ move_STACK (StgStack *src, StgStack *dest) dest->sp = (StgPtr)dest->sp + diff; } -STATIC_INLINE void +void accountAllocation(Capability *cap, W_ n) { TICK_ALLOC_HEAP_NOCTR(WDS(n)); ===================================== rts/sm/Storage.h ===================================== @@ -125,6 +125,8 @@ StgWord genLiveBlocks (generation *gen); StgWord calcTotalLargeObjectsW (void); StgWord calcTotalCompactW (void); +void accountAllocation(Capability *cap, W_ n); + /* ---------------------------------------------------------------------------- Storage manager internal APIs and globals ------------------------------------------------------------------------- */ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2cdb7dacc095142e29c0f28a956b7fa97cdb4b1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2cdb7dacc095142e29c0f28a956b7fa97cdb4b1 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 23:12:58 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 09 May 2023 19:12:58 -0400 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: JS: add GHC.JS.Optimizer, remove RTS.Printer, add Linker.Opt Message-ID: <645ad37a4decc_38ffdadb5191b4141430@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 64064cfe by doyougnu at 2023-05-09T18:40:01-04:00 JS: add GHC.JS.Optimizer, remove RTS.Printer, add Linker.Opt This MR changes some simple optimizations and is a first step in re-architecting the JS backend pipeline to add the optimizer. In particular it: - removes simple peep hole optimizations from `GHC.StgToJS.Printer` and removes that module - adds module `GHC.JS.Optimizer` - defines the same peep hole opts that were removed only now they are `Syntax -> Syntax` transformations rather than `Syntax -> JS code` optimizations - hooks the optimizer into code gen - adds FuncStat and ForStat constructors to the backend. Working Ticket: - #22736 Related MRs: - MR !10142 - MR !10000 ------------------------- Metric Decrease: CoOpt_Read ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T12707 T13253 T13253-spj T15164 T17516 T18140 T18282 T18698a T18698b T18923 T1969 T19695 T20049 T3064 T5321FD T5321Fun T783 T9198 T9233 T9630 ------------------------- - - - - - 6738c01d by Krzysztof Gogolewski at 2023-05-09T18:40:38-04:00 Add a regression test for #21050 - - - - - b2cdb7da by Ben Gamari at 2023-05-09T18:41:14-04:00 nonmoving: Account for mutator allocations in bytes_allocated Previously we failed to account direct mutator allocations into the nonmoving heap against the mutator's allocation limit and `cap->total_allocated`. This only manifests during CAF evaluation (since we allocate the CAF's blackhole directly into the nonmoving heap). Fixes #23312. - - - - - c6673873 by Sven Tennie at 2023-05-09T19:12:30-04:00 Adjust AArch64 stackFrameHeaderSize The prologue of each stack frame are the saved LR and FP registers, 8 byte each. I.e. the size of the stack frame header is 2 * 8 byte. - - - - - d137ce9c by konsumlamm at 2023-05-09T19:12:34-04:00 Make `(&)` representation polymorphic in the return type - - - - - 27 changed files: - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/JS/Make.hs - + compiler/GHC/JS/Optimizer.hs - compiler/GHC/JS/Ppr.hs - compiler/GHC/JS/Syntax.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/JS/Unsat/Syntax.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Printer.hs → compiler/GHC/StgToJS/Linker/Opt.hs - compiler/GHC/StgToJS/Object.hs - compiler/GHC/StgToJS/Rts/Rts.hs - compiler/ghc.cabal.in - libraries/base/Data/Function.hs - libraries/base/changelog.md - rts/sm/NonMovingAllocate.c - rts/sm/Storage.c - rts/sm/Storage.h - + testsuite/tests/javascript/opt/all.T - + testsuite/tests/javascript/opt/deadCodeElim.hs - + testsuite/tests/javascript/opt/deadCodeElim.stdout - testsuite/tests/linters/notes.stdout - + testsuite/tests/th/T21050.hs - + testsuite/tests/th/T21050.stderr - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/CmmToAsm/AArch64/Instr.hs ===================================== @@ -32,9 +32,9 @@ import Data.Maybe (fromMaybe) import GHC.Stack --- | TODO: verify this! -stackFrameHeaderSize :: Platform -> Int -stackFrameHeaderSize _ = 64 +-- | LR and FP (8 byte each) are the prologue of each stack frame +stackFrameHeaderSize :: Int +stackFrameHeaderSize = 2 * 8 -- | All registers are 8 byte wide. spillSlotSize :: Int @@ -49,14 +49,13 @@ stackAlign = 16 maxSpillSlots :: NCGConfig -> Int maxSpillSlots config -- = 0 -- set to zero, to see when allocMoreStack has to fire. - = let platform = ncgPlatform config - in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform) + = ((ncgSpillPreallocSize config - stackFrameHeaderSize) `div` spillSlotSize) - 1 -- | Convert a spill slot number to a *byte* offset, with no sign. spillSlotToOffset :: NCGConfig -> Int -> Int -spillSlotToOffset config slot - = stackFrameHeaderSize (ncgPlatform config) + spillSlotSize * slot +spillSlotToOffset _ slot + = stackFrameHeaderSize + spillSlotSize * slot -- | Get the registers that are being used by this instruction. -- regUsage doesn't need to do any trickery for jumps and such. ===================================== compiler/GHC/JS/Make.hs ===================================== @@ -83,7 +83,7 @@ module GHC.JS.Make -- $intro_funcs , var , jString - , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally + , jLam, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally -- * Combinators -- $combinators , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) @@ -253,7 +253,7 @@ jLam f = ValExpr . UnsatVal . IS $ do -- of the enclosed expression. The result is a block statement. -- Usage: -- --- @jVar $ \x y -> mconcat [jVar x ||= one_, jVar y ||= two_, jVar x + jVar y]@ +-- @jVar $ \x y -> mconcat [x ||= one_, y ||= two_, x + y]@ jVar :: ToSat a => a -> JStat jVar f = UnsatBlock . IS $ do (block, is) <- runIdentSupply $ toSat_ f [] @@ -262,6 +262,9 @@ jVar f = UnsatBlock . IS $ do addDecls x = x return $ addDecls block +jFunction :: Ident -> [Ident] -> JStat -> JStat +jFunction name args body = FuncStat name args body + -- | Create a 'for in' statement. -- Usage: -- @@ -279,6 +282,23 @@ jForEachIn e f = UnsatBlock . IS $ do let i = head is return $ decl i `mappend` ForInStat True i e block +-- | Create a 'for' statement given a function for initialization, a predicate +-- to step to, a step and a body +-- Usage: +-- +-- @ jFor (|= zero_) (.<. Int 65536) preIncrS +-- (\j -> ...something with the counter j...)@ +-- +jFor :: (JExpr -> JStat) + -> (JExpr -> JExpr) + -> (JExpr -> JStat) + -> (JExpr -> JStat) + -> JStat +jFor init pred step body = jVar $ \i -> ForStat (init i) (pred i) (step i) (body i) + +jForNoDecl :: Ident -> JExpr -> JExpr -> JStat -> JStat -> JStat +jForNoDecl i initial p step body = ForStat (toJExpr i |= initial) p step body + -- | As with "jForIn" but creating a \"for each in\" statement. jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat jTryCatchFinally s f s2 = UnsatBlock . IS $ do @@ -294,13 +314,6 @@ var = ValExpr . JVar . TxtI jString :: FastString -> JExpr jString = toJExpr --- | Create a 'for' statement -jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat -jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b'] - where b' = case toStat b of - BlockStat xs -> BlockStat $ xs ++ [after] - x -> BlockStat [x,after] - -- | construct a js declaration with the given identifier decl :: Ident -> JStat decl i = DeclStat i Nothing ===================================== compiler/GHC/JS/Optimizer.hs ===================================== @@ -0,0 +1,271 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Optimizer +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Optimizer is a shallow embedding of a peephole optimizer. That is, +-- this module defines transformations over the JavaScript IR in +-- 'GHC.JS.Syntax', transforming the IR forms from inefficient, or +-- non-idiomatic, JavaScript to more efficient and idiomatic JavaScript. The +-- optimizer is written in continuation passing style so optimizations +-- compose. +-- +-- * Architecture of the optimizer +-- +-- The design is that each optimization pattern matches on the head of a +-- block by pattern matching onto the head of the stream of nodes in the +-- JavaScript IR. If an optimization gets a successful match then it performs +-- whatever rewrite is necessary and then calls the 'loop' continuation. This +-- ensures that the result of the optimization is subject to the same +-- optimization, /and/ the rest of the optimizations. If there is no match +-- then the optimization should call the 'next' continuation to pass the +-- stream to the next optimization in the optimization chain. We then define +-- the last "optimization" to be @tailLoop@ which selects the next block of +-- code to optimize and begin the optimization pipeline again. +----------------------------------------------------------------------------- +module GHC.JS.Optimizer + ( jsOptimize + ) where + + +import Prelude + +import GHC.JS.Syntax + +import Control.Arrow + +{- +Note [ Unsafe JavaScript Optimizations ] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of optimizations that the JavaScript Backend performs that +are not sound with respect to arbritrary JavaScript. We still perform these +optimizations because we are not optimizing arbritrary javascript and under the +assumption that the JavaScript backend will not generate code that violates the +soundness of the optimizer. For example, the @deadCodeElim@ optimization removes +all statements that occur after a 'return' in JavaScript, however this is not +always sound because of hoisting, consider this program: + + function foo() { + var x = 2; + bar(); + return x; + + function bar() { + x = 10; + }} + + which is transformed to: + + function foo() { + var x = 2; + bar(); + return x; + }} + +The optimized form is clearly a program that goes wrong because `bar()` is no +longer defined. But the JavaScript backend will never generate this code, so as +long as that assumption holds we are safe to perform optimizations that would +normally be unsafe. +-} + + +-------------------------------------------------------------------------------- +-- Top level Driver +-------------------------------------------------------------------------------- +jsOptimize :: JStat -> JStat +jsOptimize = go + where + p_opt = jsOptimize + opt = jsOptimize' + e_opt = jExprOptimize + -- base case + go (BlockStat xs) = BlockStat (opt xs) + -- recursive cases + go (ForStat i p s body) = ForStat (go i) (e_opt p) (go s) (p_opt body) + go (ForInStat b i p body) = ForInStat b i p (p_opt body) + go (WhileStat b c body) = WhileStat b (e_opt c) (p_opt body) + go (SwitchStat s ps body) = SwitchStat s (fmap (second go) ps) (p_opt body) + go (FuncStat i args body) = FuncStat i args (p_opt body) + go (IfStat c t e) = IfStat (e_opt c) (p_opt t) (p_opt e) + go (TryStat ths i c f) = TryStat (p_opt ths) i (p_opt c) (p_opt f) + go (LabelStat lbl s) = LabelStat lbl (p_opt s) + -- special case: drive the optimizer into expressions + go (AssignStat id op rhs) = AssignStat (e_opt id) op (e_opt rhs) + go (DeclStat i (Just e)) = DeclStat i (Just $ e_opt e) + go (ReturnStat e) = ReturnStat (e_opt e) + go (UOpStat op e) = UOpStat op (e_opt e) + go (ApplStat f args) = ApplStat (e_opt f) (e_opt <$> args) + -- all else is terminal, we match on these to force a warning in the event + -- another constructor is added + go x at BreakStat{} = x + go x at ContinueStat{} = x + go x at DeclStat{} = x -- match on the nothing case + +jsOptimize' :: [JStat] -> [JStat] +jsOptimize' = runBlockOpt opts . single_pass_opts + where + opts :: BlockOpt + opts = safe_opts + <> unsafe_opts + <> tailLoop -- tailloop must be last, see module description + + unsafe_opts :: BlockOpt + unsafe_opts = mconcat [ deadCodeElim ] + + safe_opts :: BlockOpt + safe_opts = mconcat [ declareAssign, combineOps ] + + single_pass_opts :: BlockTrans + single_pass_opts = runBlockTrans sp_opts + + sp_opts = [flattenBlocks] + +-- | recur over a @JExpr@ and optimize the @JVal at s +jExprOptimize :: JExpr -> JExpr +-- the base case +jExprOptimize (ValExpr val) = ValExpr (jValOptimize val) +-- recursive cases +jExprOptimize (SelExpr obj field) = SelExpr (jExprOptimize obj) field +jExprOptimize (IdxExpr obj ix) = IdxExpr (jExprOptimize obj) (jExprOptimize ix) +jExprOptimize (UOpExpr op exp) = UOpExpr op (jExprOptimize exp) +jExprOptimize (IfExpr c t e) = IfExpr c (jExprOptimize t) (jExprOptimize e) +jExprOptimize (ApplExpr f args ) = ApplExpr (jExprOptimize f) (jExprOptimize <$> args) +jExprOptimize (InfixExpr op l r) = InfixExpr op (jExprOptimize l) (jExprOptimize r) + +-- | drive optimizations to anonymous functions and over expressions +jValOptimize :: JVal -> JVal +-- base case +jValOptimize (JFunc args body) = JFunc args (jsOptimize body) +-- recursive cases +jValOptimize (JList exprs) = JList (jExprOptimize <$> exprs) +jValOptimize (JHash hash) = JHash (jExprOptimize <$> hash) +-- all else is terminal +jValOptimize x at JVar{} = x +jValOptimize x at JDouble{} = x +jValOptimize x at JInt{} = x +jValOptimize x at JStr{} = x +jValOptimize x at JRegEx{} = x + +-- | A block transformation is a function from a stream of syntax to another +-- stream +type BlockTrans = [JStat] -> [JStat] + +-- | A BlockOpt is a function that alters the stream, and a continuation that +-- represents the rest of the stream. The first @BlockTrans@ represents +-- restarting the optimizer after a change has happened. The second @BlockTrans@ +-- represents the rest of the continuation stream. +newtype BlockOpt = BlockOpt (BlockTrans -> BlockTrans -> BlockTrans) + +-- | To merge two BlockOpt we first run the left-hand side optimization and +-- capture the right-hand side in the continuation +instance Semigroup BlockOpt where + BlockOpt opt0 <> BlockOpt opt1 = BlockOpt + $ \loop next -> opt0 loop (opt1 loop next) + +instance Monoid BlockOpt where + -- don't loop, just finalize + mempty = BlockOpt $ \_loop next -> next + +-- | loop until a fixpoint is reached +runBlockOpt :: BlockOpt -> [JStat] -> [JStat] +runBlockOpt (BlockOpt opt) xs = recur xs + where recur = opt recur id + +runBlockTrans :: [BlockTrans] -> [JStat] -> [JStat] +runBlockTrans opts = foldl (.) id opts + +-- | Perform all the optimizations on the tail of a block. +tailLoop :: BlockOpt +tailLoop = BlockOpt $ \loop next -> \case + [] -> next [] + -- this call to jsOptimize is required or else the optimizer will not + -- properly recur down JStat. See the 'deadCodeElim' test for examples which + -- were failing before this change + (x:xs) -> next (jsOptimize x : loop xs) + +-------------------------------------------------------------------------------- +-- Single Slot Optimizations +-------------------------------------------------------------------------------- + +{- | + Catch modify and assign operators: + case 1: + i = i + 1; ==> ++i; + case 2: + i = i - 1; ==> --i; + case 3: + i = i + n; ==> i += n; + case 4: + i = i - n; ==> i -= n; +-} +combineOps :: BlockOpt +combineOps = BlockOpt $ \loop next -> + \case + -- find a op pattern, and rerun the optimizer on its result unless there is + -- nothing to optimize, in which case call the next optimization + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op (ValExpr (JVar i')) e)) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- commutative cases + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op e (ValExpr (JVar i')))) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs + _ -> next $ unchanged : xs + -- general case, we had nothing to optimize in this case so call the next + -- optimization + xs -> next xs + + +-------------------------------------------------------------------------------- +-- Dual Slot Optimizations +-------------------------------------------------------------------------------- +-- | Catch 'var i; i = q;' ==> 'var i = q;' +declareAssign :: BlockOpt +declareAssign = BlockOpt $ + \loop next -> \case + ( (DeclStat i Nothing) + : (AssignStat (ValExpr (JVar i')) AssignOp v) + : xs + ) | i == i' -> loop (DeclStat i (Just v) : xs) + xs -> next xs + +-- | Eliminate all code after a return statement. This is a special case +-- optimization that doesn't need to loop. See Note [Unsafe JavaScript +-- optimizations] +deadCodeElim :: BlockOpt +deadCodeElim = BlockOpt $ + \_loop next -> \case + (x at ReturnStat{}:_) -> next [x] + xs -> next xs + +-- | remove nested blocks +flattenBlocks :: BlockTrans +flattenBlocks (BlockStat y : ys) = flattenBlocks y ++ flattenBlocks ys +flattenBlocks (x:xs) = x : flattenBlocks xs +flattenBlocks [] = [] ===================================== compiler/GHC/JS/Ppr.hs ===================================== @@ -10,10 +10,46 @@ -- For Outputable instances for JS syntax {-# OPTIONS_GHC -Wno-orphans #-} --- | Pretty-printing JavaScript +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Ppr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Ppr defines the code generation facilities for the JavaScript +-- backend. That is, this module exports a function from the JS backend IR +-- to JavaScript compliant concrete syntax that can readily be executed by +-- nodejs or called in a browser. +-- +-- * Design +-- +-- This module follows the architecture and style of the other backends in +-- GHC: it intances Outputable for the relevant types, creates a class that +-- describes a morphism from the IR domain to JavaScript concrete Syntax and +-- then generates that syntax on a case by case basis. +-- +-- * How to use +-- +-- The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record. +-- Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for +-- specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a +-- custom renderer ensures all @Ident@ generated by the linker optimization +-- pass are prefixed differently than the default. Use @renderJS@ to +-- generate JavaScript concrete syntax in the general case, suitable for +-- human consumption. +----------------------------------------------------------------------------- + module GHC.JS.Ppr ( renderJs - , renderJs' , renderPrefixJs , renderPrefixJs' , JsToDoc(..) @@ -21,9 +57,10 @@ module GHC.JS.Ppr , RenderJs(..) , jsToDoc , pprStringLit - , flattenBlocks , braceNest , hangBrace + , interSemi + , addSemi ) where @@ -49,9 +86,9 @@ instance Outputable JExpr where instance Outputable JVal where ppr = docToSDoc . renderJs - -($$$) :: Doc -> Doc -> Doc -x $$$ y = nest 2 $ x $+$ y +-------------------------------------------------------------------------------- +-- Top level API +-------------------------------------------------------------------------------- -- | Render a syntax tree as a pretty-printable document -- (simply showing the resultant doc produces a nice, @@ -84,26 +121,17 @@ renderPrefixJs = renderPrefixJs' defaultRenderJs renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc renderPrefixJs' r = jsToDocR r -braceNest :: Doc -> Doc -braceNest x = char '{' <+> nest 2 x $$ char '}' - --- | Hang with braces: --- --- hdr { --- body --- } -hangBrace :: Doc -> Doc -> Doc -hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] +-------------------------------------------------------------------------------- +-- Code Generator +-------------------------------------------------------------------------------- class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc -instance JsToDoc JStat where jsToDocR r = renderJsS r r -instance JsToDoc JExpr where jsToDocR r = renderJsE r r -instance JsToDoc JVal where jsToDocR r = renderJsV r r -instance JsToDoc Ident where jsToDocR r = renderJsI r r -instance JsToDoc [JExpr] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) -instance JsToDoc [JStat] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc JStat where jsToDocR r = renderJsS r r +instance JsToDoc JExpr where jsToDocR r = renderJsE r r +instance JsToDoc JVal where jsToDocR r = renderJsV r r +instance JsToDoc Ident where jsToDocR r = renderJsI r r +instance JsToDoc [JExpr] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc [JStat] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r) defRenderJsS :: RenderJs -> JStat -> Doc defRenderJsS r = \case @@ -120,12 +148,16 @@ defRenderJsS r = \case ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s where - printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss + printBS (BlockStat ss) = vcat $ interSemi $ map (jsToDocR r) ss printBS x = jsToDocR r x - interSemi [x] = [jsToDocR r x] - interSemi [] = [] - interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs + ForStat init p s1 sb -> hangBrace (text "for" <> forCond) (jsToDocR r sb) + where + forCond = parens $ hcat $ interSemi + [ jsToDocR r init + , jsToDocR r p + , parens (jsToDocR r s1) + ] ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b) where txt | each = "for each" | otherwise = "for" @@ -134,12 +166,15 @@ defRenderJsS r = \case cases = vcat l' ReturnStat e -> text "return" <+> jsToDocR r e ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es) + FuncStat i is b -> hangBrace (text "function" <+> jsToDocR r i + <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) + (jsToDocR r b) TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally where mbCatch | s1 == BlockStat [] = PP.empty | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1) mbFinally | s2 == BlockStat [] = PP.empty | otherwise = hangBrace (text "finally") (jsToDocR r s2) - AssignStat i x -> case x of + AssignStat i op x -> case x of -- special treatment for functions, otherwise there is too much left padding -- (more than the length of the expression assigned to). E.g. -- @@ -148,19 +183,13 @@ defRenderJsS r = \case -- ... -- }); -- - ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] - _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x + ValExpr (JFunc is b) -> sep [jsToDocR r i <+> ftext (aOpText op) <+> text " function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] + _ -> jsToDocR r i <+> ftext (aOpText op) <+> jsToDocR r x UOpStat op x | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x | isPre op -> ftext (uOpText op) <> optParens r x | otherwise -> optParens r x <> ftext (uOpText op) - BlockStat xs -> jsToDocR r (flattenBlocks xs) - -flattenBlocks :: [JStat] -> [JStat] -flattenBlocks = \case - BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys - y:ys -> y : flattenBlocks ys - [] -> [] + BlockStat xs -> jsToDocR r xs optParens :: RenderJs -> JExpr -> Doc optParens r x = case x of @@ -204,33 +233,12 @@ defRenderJsV r = \case defRenderJsI :: RenderJs -> Ident -> Doc defRenderJsI _ (TxtI t) = ftext t +aOpText :: AOp -> FastString +aOpText = \case + AssignOp -> "=" + AddAssignOp -> "+=" + SubAssignOp -> "-=" -pprStringLit :: FastString -> Doc -pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] - -encodeJson :: FastString -> Doc -encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) - -encodeJsonChar :: Char -> Doc -encodeJsonChar = \case - '/' -> text "\\/" - '\b' -> text "\\b" - '\f' -> text "\\f" - '\n' -> text "\\n" - '\r' -> text "\\r" - '\t' -> text "\\t" - '"' -> text "\\\"" - '\\' -> text "\\\\" - c - | not (isControl c) && ord c <= 127 -> char c - | ord c <= 0xff -> hexxs "\\x" 2 (ord c) - | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) - | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair - in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> - hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) - where hexxs prefix pad cp = - let h = showHex cp "" - in text (prefix ++ replicate (pad - length h) '0' ++ h) uOpText :: UOp -> FastString uOpText = \case @@ -289,3 +297,56 @@ isAlphaOp = \case YieldOp -> True VoidOp -> True _ -> False + +pprStringLit :: FastString -> Doc +pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +encodeJson :: FastString -> Doc +encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) + +encodeJsonChar :: Char -> Doc +encodeJsonChar = \case + '/' -> text "\\/" + '\b' -> text "\\b" + '\f' -> text "\\f" + '\n' -> text "\\n" + '\r' -> text "\\r" + '\t' -> text "\\t" + '"' -> text "\\\"" + '\\' -> text "\\\\" + c + | not (isControl c) && ord c <= 127 -> char c + | ord c <= 0xff -> hexxs "\\x" 2 (ord c) + | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) + | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair + in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> + hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) + where hexxs prefix pad cp = + let h = showHex cp "" + in text (prefix ++ replicate (pad - length h) '0' ++ h) + +braceNest :: Doc -> Doc +braceNest x = char '{' <+> nest 2 x $$ char '}' + +interSemi :: [Doc] -> [Doc] +interSemi [] = [] +interSemi [s] = [s] +interSemi (x:xs) = x <> text ";" : interSemi xs + +addSemi :: Doc -> Doc +addSemi x = x <> text ";" + +-- | Hang with braces: +-- +-- hdr { +-- body +-- } +hangBrace :: Doc -> Doc -> Doc +hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] + +($$$) :: Doc -> Doc -> Doc +x $$$ y = nest 2 $ x $+$ y ===================================== compiler/GHC/JS/Syntax.hs ===================================== @@ -58,6 +58,7 @@ module GHC.JS.Syntax , JVal(..) , Op(..) , UOp(..) + , AOp(..) , Ident(..) , JLabel -- * pattern synonyms over JS operators @@ -110,20 +111,22 @@ import GHC.Generics -- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) -- for details data JStat - = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] - | ReturnStat JExpr -- ^ Return - | IfStat JExpr JStat JStat -- ^ If + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForStat JStat JExpr JStat JStat -- ^ For | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch | TryStat JStat Ident JStat JStat -- ^ Try - | BlockStat [JStat] -- ^ Blocks - | ApplStat JExpr [JExpr] -- ^ Application - | UOpStat UOp JExpr -- ^ Unary operators - | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ - | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic - | BreakStat (Maybe JLabel) -- ^ Break - | ContinueStat (Maybe JLabel) -- ^ Continue + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat UOp JExpr -- ^ Unary operators + | AssignStat JExpr AOp JExpr -- ^ Binding form: @ @ + | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JLabel) -- ^ Break + | ContinueStat (Maybe JLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition deriving (Eq, Typeable, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of @@ -146,9 +149,9 @@ appendJStat mx my = case (mx,my) of (BlockStat [] , y ) -> y (x , BlockStat []) -> x (BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys - (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] - (xs , BlockStat ys) -> BlockStat $! xs : ys - (xs , ys ) -> BlockStat [xs,ys] + (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $! xs : ys + (xs , ys ) -> BlockStat [xs,ys] -------------------------------------------------------------------------------- @@ -156,13 +159,13 @@ appendJStat mx my = case (mx,my) of -------------------------------------------------------------------------------- -- | JavaScript Expressions data JExpr - = ValExpr JVal -- ^ All values are trivially expressions - | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' - | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' - | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms - | UOpExpr UOp JExpr -- ^ Unary Expressions + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms + | UOpExpr UOp JExpr -- ^ Unary Expressions | IfExpr JExpr JExpr JExpr -- ^ If-expression - | ApplExpr JExpr [JExpr] -- ^ Application + | ApplExpr JExpr [JExpr] -- ^ Application deriving (Eq, Typeable, Generic) -- * Useful pattern synonyms to ease programming with the deeply embedded JS @@ -321,6 +324,15 @@ data UOp instance NFData UOp +-- | JS Unary Operators +data AOp + = AssignOp -- ^ Vanilla Assignment: = + | AddAssignOp -- ^ Addition Assignment: += + | SubAssignOp -- ^ Subtraction Assignment: -= + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData AOp + -- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' -- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on -- Sane-ness @@ -345,10 +357,12 @@ instance Show SaneDouble where -------------------------------------------------------------------------------- jassignAllEqual :: [JExpr] -> [JExpr] -> JStat -jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" AssignStat xs ys) +jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" go xs ys) + where go l r = AssignStat l AssignOp r jassignAll :: [JExpr] -> [JExpr] -> JStat -jassignAll xs ys = mconcat (zipWith AssignStat xs ys) +jassignAll xs ys = mconcat $ zipWith go xs ys + where go l r = AssignStat l AssignOp r jvar :: FastString -> JExpr jvar = ValExpr . JVar . TxtI ===================================== compiler/GHC/JS/Transform.hs ===================================== @@ -47,6 +47,7 @@ identsS = \case Sat.ReturnStat e -> identsE e Sat.IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 Sat.WhileStat _ e s -> identsE e ++ identsS s + Sat.ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body Sat.ForInStat _ i e s -> [i] ++ identsE e ++ identsS s Sat.SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s where traverseCase (e,s) = identsE e ++ identsS s @@ -54,10 +55,11 @@ identsS = \case Sat.BlockStat xs -> concatMap identsS xs Sat.ApplStat e es -> identsE e ++ concatMap identsE es Sat.UOpStat _op e -> identsE e - Sat.AssignStat e1 e2 -> identsE e1 ++ identsE e2 + Sat.AssignStat e1 _op e2 -> identsE e1 ++ identsE e2 Sat.LabelStat _l s -> identsS s Sat.BreakStat{} -> [] Sat.ContinueStat{} -> [] + Sat.FuncStat i args body -> [i] ++ args ++ identsS body {-# INLINE identsE #-} identsE :: Sat.JExpr -> [Ident] @@ -148,6 +150,8 @@ jmcompos ret app f' v = ReturnStat i -> ret ReturnStat `app` f i IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s' WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s + ForStat init p step body -> ret ForStat `app` f init `app` f p + `app` f step `app` f body ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l @@ -158,6 +162,7 @@ jmcompos ret app f' v = AssignStat e e' -> ret AssignStat `app` f e `app` f e' UnsatBlock _ -> ret v' ContinueStat l -> ret (ContinueStat l) + FuncStat i args body -> ret FuncStat `app` f i `app` mapM' f args `app` f body BreakStat l -> ret (BreakStat l) LabelStat l s -> ret (LabelStat l) `app` f s JMGExpr v' -> ret JMGExpr `app` case v' of @@ -217,7 +222,6 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) -------------------------------------------------------------------------------- -- Translation -- --- This will be moved after GHC.JS.Syntax is removed -------------------------------------------------------------------------------- satJStat :: JStat -> Sat.JStat satJStat = witness . proof @@ -229,6 +233,9 @@ satJStat = witness . proof witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) + witness (ForStat init p step body) = Sat.ForStat + (witness init) (satJExpr p) + (witness step) (witness body) witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i (satJExpr iter) (witness body) @@ -240,12 +247,13 @@ satJStat = witness . proof witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs) + witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) Sat.AssignOp (satJExpr rhs) witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) witness (BreakStat Nothing) = Sat.BreakStat Nothing witness (BreakStat (Just l)) = Sat.BreakStat $! Just l witness (ContinueStat Nothing) = Sat.ContinueStat Nothing witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l + witness (FuncStat i args body) = Sat.FuncStat i args (witness body) witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" ===================================== compiler/GHC/JS/Unsat/Syntax.hs ===================================== @@ -146,6 +146,7 @@ data JStat | ReturnStat JExpr -- ^ Return | IfStat JExpr JStat JStat -- ^ If | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForStat JStat JExpr JStat JStat -- ^ For | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch | TryStat JStat Ident JStat JStat -- ^ Try @@ -157,6 +158,7 @@ data JStat | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic | BreakStat (Maybe JsLabel) -- ^ Break | ContinueStat (Maybe JsLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition deriving (Eq, Typeable, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of ===================================== compiler/GHC/StgToJS/Apply.hs ===================================== @@ -408,17 +408,11 @@ mkApplyArr = mconcat [ TxtI "h$apply" ||= toJExpr (JList []) , TxtI "h$paps" ||= toJExpr (JList []) , ApplStat (var "h$initStatic" .^ "push") - [ ValExpr $ JFunc [] $ jVar \i -> mconcat - [ i |= zero_ - , WhileStat False (i .<. Int 65536) $ mconcat - [ var "h$apply" .! i |= var "h$ap_gen" - , preIncrS i - ] - , i |= zero_ - , WhileStat False (i .<. Int 128) $ mconcat - [ var "h$paps" .! i |= var "h$pap_gen" - , preIncrS i - ] + [ ValExpr $ JFunc [] $ mconcat + [ jFor (|= zero_) (.<. Int 65536) preIncrS + (\j -> var "h$apply" .! j |= var "h$ap_gen") + , jFor (|= zero_) (.<. Int 128) preIncrS + (\j -> var "h$paps" .! j |= var "h$pap_gen") , mconcat (map assignSpec applySpec) , mconcat (map assignPap specPap) ] ===================================== compiler/GHC/StgToJS/CodeGen.hs ===================================== @@ -16,6 +16,7 @@ import GHC.JS.Ppr import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Arg import GHC.StgToJS.Sinker @@ -133,10 +134,10 @@ genUnits m ss spt_entries foreign_stubs = do glbl <- State.gets gsGlobal staticInit <- initStaticPtrs spt_entries - let stat = ( -- O.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m 1) - $ mconcat (reverse glbl) <> staticInit) + let stat = ( jsOptimize + . satJStat + . jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) let syms = [moduleGlobalSymbol m] let oi = ObjUnit { oiSymbols = syms @@ -208,7 +209,9 @@ genUnits m ss spt_entries foreign_stubs = do _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body + let stat = jsOptimize + . satJStat + $ jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] syms <- (\(TxtI i) -> [i]) <$> identForId bnd let oi = ObjUnit @@ -245,10 +248,10 @@ genUnits m ss spt_entries foreign_stubs = do let allDeps = collectIds unf decl topDeps = collectTopIds decl required = hasExport decl - stat = -- Opt.optimize . - satJStat . - jsSaturate (Just $ modulePrefix m n) - $ mconcat (reverse extraTl) <> tl + stat = jsOptimize + . satJStat + . jsSaturate (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps let oi = ObjUnit { oiSymbols = syms @@ -308,15 +311,15 @@ genSetConInfo i d l {- srt -} = do (fixedLayout $ map uTypeVt fields) (CICon $ dataConTag d) sr - return (ei ||= mkDataEntry) + return (mkDataEntry ei) where -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug? fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing) (dataConRepArgTys d) -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d) -mkDataEntry :: JExpr -mkDataEntry = ValExpr $ JFunc [] returnStack +mkDataEntry :: Ident -> JStat +mkDataEntry i = FuncStat i [] returnStack genToplevelRhs :: Id -> CgStgRhs -> G JStat -- general cases: ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -240,7 +240,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = body <- genBody ctx R1 args body typ ei@(TxtI eii) <- identForEntryId i sr <- genStaticRefsRhs rhs - let f = JFunc [] (bh <> lvs <> body) + let f = (bh <> lvs <> body) emitClosureInfo $ ClosureInfo ei (CIRegs 0 $ concatMap idVt args) @@ -249,7 +249,7 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = map (stackSlotType . fst) (ctxLneFrameVars ctx)) CIStackFrame sr - emitToplevel (ei ||= toJExpr f) + emitToplevel (jFunction ei [] f) genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do let payloadSize = ctxLneFrameSize ctx ei@(TxtI _eii) <- identForEntryId i @@ -258,8 +258,7 @@ genEntryLne ctx i (StgRhsCon cc con _mu _ticks args _typ) = resetSlots $ do p <- popLneFrame True payloadSize ctx args' <- concatMapM genArg args ac <- allocCon ii con cc args' - emitToplevel (ei ||= toJExpr (JFunc [] - (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack]))) + emitToplevel (jFunction ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])) -- | Generate the entry function for a local closure genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () @@ -283,7 +282,7 @@ genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body typ) = (fixedLayout $ map (uTypeVt . idType) live) et sr - emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + emitToplevel (jFunction ei [] (mconcat [ll, llv, upd, setcc, body])) where entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) @@ -630,7 +629,7 @@ genRet ctx e at as l = freshIdent >>= f ++ if prof then [ObjV] else map stackSlotType lneVars) CIStackFrame sr - emitToplevel $ r ||= toJExpr (JFunc [] fun') + emitToplevel $ jFunction r [] fun' return (pushLne <> saveCCS <> pushRet) fst3 ~(x,_,_) = x ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -30,6 +30,7 @@ import Prelude import GHC.Platform.Host (hostPlatformArchOS) import GHC.JS.Make +import GHC.JS.Optimizer import GHC.JS.Unsat.Syntax import qualified GHC.JS.Syntax as Sat import GHC.JS.Transform @@ -43,11 +44,11 @@ import GHC.Linker.Static.Utils (exeFileName) import GHC.StgToJS.Linker.Types import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Linker.Opt import GHC.StgToJS.Rts.Rts import GHC.StgToJS.Object import GHC.StgToJS.Types hiding (LinkableUnit) import GHC.StgToJS.Symbols -import GHC.StgToJS.Printer import GHC.StgToJS.Arg import GHC.StgToJS.Closure @@ -332,7 +333,7 @@ renderLinker h mods jsFiles = do pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (satJStat meta) + !meta_length <- fromIntegral <$> putJS (jsOptimize $ satJStat meta) -- module exports mapM_ (putBS . cmc_exports) compacted_mods ===================================== compiler/GHC/StgToJS/Printer.hs → compiler/GHC/StgToJS/Linker/Opt.hs ===================================== @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | --- Module : GHC.StgToJS.Printer +-- Module : GHC.StgToJS.Linker.Opt -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE) -- @@ -13,15 +13,14 @@ -- Sylvain Henry -- Stability : experimental -- --- Custom prettyprinter for JS AST uses the JS PPr module for most of --- the work +-- Optimization pass at link time +-- -- -- ----------------------------------------------------------------------------- -module GHC.StgToJS.Printer +module GHC.StgToJS.Linker.Opt ( pretty , ghcjsRenderJs - , prettyBlock ) where @@ -93,8 +92,7 @@ hexDoc v = text $ go v -- attempt to resugar some of the common constructs ghcjsRenderJsS :: RenderJs -> JStat -> Doc -ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) -ghcjsRenderJsS r s = renderJsS defaultRenderJs r s +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s -- don't quote keys in our object literals, so closure compiler works ghcjsRenderJsV :: RenderJs -> JVal -> Doc @@ -120,97 +118,3 @@ ghcjsRenderJsV r (JHash m) validOtherIdent c = isAlpha c || isDigit c ghcjsRenderJsV r v = renderJsV defaultRenderJs r v - -prettyBlock :: RenderJs -> [JStat] -> Doc -prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs) - --- recognize common patterns in a block and convert them to more idiomatic/concise javascript -prettyBlock' :: RenderJs -> [JStat] -> [Doc] --- return/... -prettyBlock' r ( x@(ReturnStat _) - : xs - ) - | not (null xs) - = prettyBlock' r [x] --- declare/assign -prettyBlock' r ( (DeclStat i Nothing) - : (AssignStat (ValExpr (JVar i')) v) - : xs - ) - | i == i' - = prettyBlock' r (DeclStat i (Just v) : xs) - --- resugar for loops with/without var declaration -prettyBlock' r ( (DeclStat i (Just v0)) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs - --- global function (does not preserve semantics but works for GHCJS) -prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b)))) - : xs - ) - = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) - (jsToDocR r b) - ) : prettyBlock' r xs --- modify/assign operators -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs - - -prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs -prettyBlock' _ [] = [] - --- build the for block -mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc -mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond) - (jsToDocR r $ BlockStat sb) - where - c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0 - | otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0 - forCond = parens $ hcat $ interSemi - [ c0 - , jsToDocR r p - , parens (jsToDocR r s1) - ] - --- check if a statement is suitable to be converted to something in the for(;;x) position -isForUpdStat :: JStat -> Bool -isForUpdStat UOpStat {} = True -isForUpdStat AssignStat {} = True -isForUpdStat ApplStat {} = True -isForUpdStat _ = False - -interSemi :: [Doc] -> [Doc] -interSemi [] = [PP.empty] -interSemi [s] = [s] -interSemi (x:xs) = x <> text ";" : interSemi xs - -addSemi :: Doc -> Doc -addSemi x = x <> text ";" ===================================== compiler/GHC/StgToJS/Object.hs ===================================== @@ -408,31 +408,35 @@ instance Binary Sat.JStat where put_ bh (Sat.ReturnStat e) = putByte bh 2 >> put_ bh e put_ bh (Sat.IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 put_ bh (Sat.WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s - put_ bh (Sat.ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s - put_ bh (Sat.SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s - put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 - put_ bh (Sat.BlockStat xs) = putByte bh 8 >> put_ bh xs - put_ bh (Sat.ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es - put_ bh (Sat.UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e - put_ bh (Sat.AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 - put_ bh (Sat.LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s - put_ bh (Sat.BreakStat ml) = putByte bh 13 >> put_ bh ml - put_ bh (Sat.ContinueStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ForStat is c s bd) = putByte bh 5 >> put_ bh is >> put_ bh c >> put_ bh s >> put_ bh bd + put_ bh (Sat.ForInStat b i e s) = putByte bh 6 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (Sat.SwitchStat e ss s) = putByte bh 7 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 8 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (Sat.BlockStat xs) = putByte bh 9 >> put_ bh xs + put_ bh (Sat.ApplStat e es) = putByte bh 10 >> put_ bh e >> put_ bh es + put_ bh (Sat.UOpStat o e) = putByte bh 11 >> put_ bh o >> put_ bh e + put_ bh (Sat.AssignStat e1 op e2) = putByte bh 12 >> put_ bh e1 >> put_ bh op >> put_ bh e2 + put_ bh (Sat.LabelStat l s) = putByte bh 13 >> put_ bh l >> put_ bh s + put_ bh (Sat.BreakStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ContinueStat ml) = putByte bh 15 >> put_ bh ml + put_ bh (Sat.FuncStat i is b) = putByte bh 16 >> put_ bh i >> put_ bh is >> put_ bh b get bh = getByte bh >>= \case 1 -> Sat.DeclStat <$> get bh <*> get bh 2 -> Sat.ReturnStat <$> get bh 3 -> Sat.IfStat <$> get bh <*> get bh <*> get bh 4 -> Sat.WhileStat <$> get bh <*> get bh <*> get bh - 5 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh - 6 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh - 7 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh - 8 -> Sat.BlockStat <$> get bh - 9 -> Sat.ApplStat <$> get bh <*> get bh - 10 -> Sat.UOpStat <$> get bh <*> get bh - 11 -> Sat.AssignStat <$> get bh <*> get bh - 12 -> Sat.LabelStat <$> get bh <*> get bh - 13 -> Sat.BreakStat <$> get bh - 14 -> Sat.ContinueStat <$> get bh + 5 -> Sat.ForStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 7 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh + 8 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 9 -> Sat.BlockStat <$> get bh + 10 -> Sat.ApplStat <$> get bh <*> get bh + 11 -> Sat.UOpStat <$> get bh <*> get bh + 12 -> Sat.AssignStat <$> get bh <*> get bh <*> get bh + 13 -> Sat.LabelStat <$> get bh <*> get bh + 14 -> Sat.BreakStat <$> get bh + 15 -> Sat.ContinueStat <$> get bh + 16 -> Sat.FuncStat <$> get bh <*> get bh <*> get bh n -> error ("Binary get bh JStat: invalid tag: " ++ show n) @@ -541,6 +545,10 @@ instance Binary Sat.UOp where put_ bh = putEnum bh get bh = getEnum bh +instance Binary Sat.AOp where + put_ bh = putEnum bh + get bh = getEnum bh + -- 16 bit sizes should be enough... instance Binary CILayout where put_ bh CILayoutVariable = putByte bh 1 ===================================== compiler/GHC/StgToJS/Rts/Rts.hs ===================================== @@ -30,16 +30,18 @@ import GHC.Prelude import GHC.JS.Unsat.Syntax import GHC.JS.Make import GHC.JS.Transform +import GHC.JS.Optimizer import GHC.StgToJS.Apply import GHC.StgToJS.Closure import GHC.StgToJS.Heap -import GHC.StgToJS.Printer import GHC.StgToJS.Profiling import GHC.StgToJS.Regs import GHC.StgToJS.Types import GHC.StgToJS.Stack +import GHC.StgToJS.Linker.Opt + import GHC.Data.FastString import GHC.Types.Unique.Map @@ -134,7 +136,7 @@ closureConstructors s = BlockStat | otherwise = mempty mkClosureCon :: Maybe Int -> JStat - mkClosureCon n0 = funName ||= toJExpr fun + mkClosureCon n0 = jFunction funName args funBod where n | Just n' <- n0 = n' | Nothing <- n0 = 0 @@ -142,7 +144,6 @@ closureConstructors s = BlockStat | Nothing <- n0 = TxtI $ mkFastString "h$c" -- args are: f x1 x2 .. xn [cc] args = TxtI "f" : addCCArg' (map varName [1..n]) - fun = JFunc args funBod -- x1 goes into closureField1. All the other args are bundled into an -- object in closureField2: { d1 = x2, d2 = x3, ... } -- @@ -157,12 +158,12 @@ closureConstructors s = BlockStat ] mkDataFill :: Int -> JStat - mkDataFill n = funName ||= toJExpr fun + mkDataFill n = jFunction funName (map TxtI ds) body where funName = TxtI $ dataName n ds = map dataFieldName [1..n] extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds - fun = JFunc (map TxtI ds) (checkD <> returnS extra_args) + body = (checkD <> returnS extra_args) -- | JS Payload to perform stack manipulation in the RTS stackManip :: JStat @@ -172,10 +173,10 @@ stackManip = mconcat (map mkPush [1..32]) <> mkPush :: Int -> JStat mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) as = map varName [1..n] - fun = JFunc as ((sp |= sp + toJExpr n) - <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) - [1..] as)) - in funName ||= toJExpr fun + body = ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + [1..] as)) + in jFunction funName as body -- partial pushes, based on bitmap, increases Sp by highest bit mkPpush :: Integer -> JStat @@ -185,11 +186,10 @@ stackManip = mconcat (map mkPush [1..32]) <> n = length bits h = last bits args = map varName [1..n] - fun = JFunc args $ - mconcat [ sp |= sp + toJExpr (h+1) - , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) - ] - in funName ||= toJExpr fun + body = mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) + ] + in jFunction funName args body bitsIdx :: Integer -> [Int] bitsIdx n | n < 0 = error "bitsIdx: negative" @@ -244,12 +244,12 @@ loadRegs :: JStat loadRegs = mconcat $ map mkLoad [1..32] where mkLoad :: Int -> JStat - mkLoad n = let args = map varName [1..n] - assign = zipWith (\a r -> toJExpr r |= toJExpr a) - args (reverse $ take n regsFromR1) - fname = TxtI $ mkFastString ("h$l" ++ show n) - fun = JFunc args (mconcat assign) - in fname ||= toJExpr fun + mkLoad n = let args = map varName [1..n] + body = mconcat $ + zipWith (\a r -> toJExpr r |= toJExpr a) + args (reverse $ take n regsFromR1) + fname = TxtI $ mkFastString ("h$l" ++ show n) + in jFunction fname args body -- | Assign registers R1 ... Rn in descending order, that is assign Rn first. -- This function uses the 'assignRegs'' array to construct functions which set @@ -314,11 +314,11 @@ rtsDecls = jsSaturate (Just "h$RTSD") $ -- | print the embedded RTS to a String rtsText :: StgToJSConfig -> String -rtsText = show . pretty . satJStat . rts +rtsText = show . pretty . jsOptimize . satJStat . rts -- | print the RTS declarations to a String. rtsDeclsText :: String -rtsDeclsText = show . pretty . satJStat $ rtsDecls +rtsDeclsText = show . pretty . jsOptimize . satJStat $ rtsDecls -- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' rts :: StgToJSConfig -> JStat ===================================== compiler/ghc.cabal.in ===================================== @@ -532,6 +532,7 @@ Library GHC.IfaceToCore GHC.Iface.Type GHC.JS.Make + GHC.JS.Optimizer GHC.JS.Ppr GHC.JS.Syntax GHC.JS.Transform @@ -672,7 +673,6 @@ Library GHC.StgToJS.Object GHC.StgToJS.Prim GHC.StgToJS.Profiling - GHC.StgToJS.Printer GHC.StgToJS.Regs GHC.StgToJS.Rts.Types GHC.StgToJS.Rts.Rts @@ -686,6 +686,7 @@ Library GHC.StgToJS.Linker.Linker GHC.StgToJS.Linker.Types GHC.StgToJS.Linker.Utils + GHC.StgToJS.Linker.Opt GHC.Stg.Unarise GHC.SysTools GHC.SysTools.Ar ===================================== libraries/base/Data/Function.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} @@ -28,7 +30,7 @@ module Data.Function , applyWhen ) where -import GHC.Base ( ($), (.), id, const, flip ) +import GHC.Base ( TYPE, ($), (.), id, const, flip ) import Data.Bool ( Bool(..) ) infixl 0 `on` @@ -120,7 +122,7 @@ on :: (b -> b -> c) -> (a -> b) -> a -> a -> c -- "6" -- -- @since 4.8.0.0 -(&) :: a -> (a -> b) -> b +(&) :: forall r a (b :: TYPE r). a -> (a -> b) -> b x & f = f x -- | 'applyWhen' applies a function to a value if a condition is true, ===================================== libraries/base/changelog.md ===================================== @@ -21,9 +21,10 @@ ([CLC proposal #149](https://github.com/haskell/core-libraries-committee/issues/149)) * Make `($)` representation polymorphic ([CLC proposal #132](https://github.com/haskell/core-libraries-committee/issues/132)) * Implemented [GHC Proposal #433](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst), - adding the class `Unsatisfiable :: ErrorMessage -> TypeError`` to `GHC.TypeError`, + adding the class `Unsatisfiable :: ErrorMessage -> TypeError` to `GHC.TypeError`, which provides a mechanism for custom type errors that reports the errors in - a more predictable behaviour than ``TypeError``. + a more predictable behaviour than `TypeError`. + * Make `(&)` representation polymorphic in the return type ([CLC proposal #158](https://github.com/haskell/core-libraries-committee/issues/158)) ## 4.18.0.0 *March 2023* * Shipped with GHC 9.6.1 ===================================== rts/sm/NonMovingAllocate.c ===================================== @@ -253,5 +253,9 @@ void *nonmovingAllocateGC(Capability *cap, StgWord sz) GNUC_ATTR_HOT void *nonmovingAllocate(Capability *cap, StgWord sz) { + // Handle "bytes allocated" accounting in the same way we + // do in Storage.c:allocate. See #23312. + accountAllocation(cap, sz); + cap->total_allocated += sz; return nonmovingAllocate_(SM_LOCK, cap, sz); } ===================================== rts/sm/Storage.c ===================================== @@ -966,7 +966,7 @@ move_STACK (StgStack *src, StgStack *dest) dest->sp = (StgPtr)dest->sp + diff; } -STATIC_INLINE void +void accountAllocation(Capability *cap, W_ n) { TICK_ALLOC_HEAP_NOCTR(WDS(n)); ===================================== rts/sm/Storage.h ===================================== @@ -125,6 +125,8 @@ StgWord genLiveBlocks (generation *gen); StgWord calcTotalLargeObjectsW (void); StgWord calcTotalCompactW (void); +void accountAllocation(Capability *cap, W_ n); + /* ---------------------------------------------------------------------------- Storage manager internal APIs and globals ------------------------------------------------------------------------- */ ===================================== testsuite/tests/javascript/opt/all.T ===================================== @@ -0,0 +1,4 @@ +# These are JavaScript-specific tests for the JS backend optimizer +setTestOpts(when(not(js_arch()),skip)) + +test('deadCodeElim', normal, compile_and_run, ['-package ghc']) ===================================== testsuite/tests/javascript/opt/deadCodeElim.hs ===================================== @@ -0,0 +1,96 @@ + +import GHC.JS.Optimizer +import GHC.JS.Syntax +import GHC.JS.Unsat.Syntax (Ident (..)) + +import GHC.Data.FastString + +double_return :: JStat +double_return = BlockStat [ ReturnStat (SatInt 0) + , ReturnStat (SatInt 1) + ] + +double_return_opt :: JStat +double_return_opt = (BlockStat [ReturnStat (SatInt 0)]) + +in_func :: JStat +in_func = AssignStat (jvar (fsLit "foo")) AssignOp (ValExpr (JFunc [] double_return)) + +in_func_opt :: JStat +in_func_opt = AssignStat (jvar (fsLit "foo")) AssignOp (ValExpr (JFunc [] double_return_opt)) + +nested_blocks :: JStat +nested_blocks = BlockStat [ double_return <> double_return + , double_return + ] <> double_return + +nested_blocks_opt :: JStat +nested_blocks_opt = double_return_opt + +global_func :: JStat +global_func = FuncStat (TxtI (fsLit "bar")) [] double_return + +global_func_opt :: JStat +global_func_opt = FuncStat (TxtI (fsLit "bar")) [] double_return_opt + +func_with_locals :: JStat +func_with_locals = AssignStat (jvar (fsLit "foo")) + AssignOp + (ValExpr (JFunc [] + (BlockStat [ AssignStat (jvar (fsLit "one")) AssignOp (SatInt 2) + , AssignStat (jvar (fsLit "two")) AssignOp (SatInt 3) + , ApplStat (jvar (fsLit "f")) [(SatInt 100)] + , ReturnStat (SatInt 0) + , ReturnStat (SatInt 1) + ]))) + +func_with_locals_opt :: JStat +func_with_locals_opt = AssignStat (jvar (fsLit "foo")) + AssignOp + (ValExpr (JFunc [] + (BlockStat [ AssignStat (jvar (fsLit "one")) AssignOp (SatInt 2) + , AssignStat (jvar (fsLit "two")) AssignOp (SatInt 3) + , ApplStat (jvar (fsLit "f")) [(SatInt 100)] + , ReturnStat (SatInt 0) + ]))) + +-- This one comes straight from MR10260 where we noticed the optimizer was not catching the redundant return +bignum_test :: JStat +bignum_test = DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + , ReturnStat (ApplExpr (jvar $ fsLit "h$rs") [])])) + +bignum_test_opt :: JStat +bignum_test_opt = + DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + ])) + +bignum_test_2 :: JStat +bignum_test_2 = BlockStat [FuncStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99") [] (BlockStat [DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + , ReturnStat (ApplExpr (jvar $ fsLit "h$rs") [])]))])] + +bignum_test_opt_2 :: JStat +bignum_test_opt_2 = BlockStat [FuncStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99") [] (BlockStat [DeclStat (TxtI $ fsLit "h$ghczmbignumZCGHCziNumziIntegerziintegerToInt64zh_e") + (Just (ValExpr $ JFunc [] $ BlockStat [ DeclStat (TxtI $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e") (Just (jvar $ fsLit "h$r2")) + , ApplStat (jvar $ fsLit "h$p1") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziInteger_99"] + , ReturnStat (ApplExpr (jvar $ fsLit "h$e") [jvar $ fsLit "h$$ghczmbignumZCGHCziNumziIntegerzids_s_2f9e"]) + ]))])] + +main :: IO () +main = mapM_ print + [ jsOptimize double_return == double_return_opt + , jsOptimize in_func == in_func_opt + , jsOptimize nested_blocks == nested_blocks_opt + , jsOptimize global_func == global_func_opt + , jsOptimize func_with_locals == func_with_locals_opt + , jsOptimize bignum_test == bignum_test_opt + , jsOptimize bignum_test_2 == bignum_test_opt_2 + ] ===================================== testsuite/tests/javascript/opt/deadCodeElim.stdout ===================================== @@ -0,0 +1,7 @@ +True +True +True +True +True +True +True ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -7,7 +7,7 @@ ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] ref compiler/GHC/Core/Opt/Specialise.hs:1790:28: Note [Arity decrease] ref compiler/GHC/Core/TyCo/Rep.hs:1556:31: Note [What prevents a constraint from floating] ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Driver/Session.hs:3993:49: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Session.hs:4062:49: Note [Eta-reduction in -O0] ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] ref compiler/GHC/Hs/Expr.hs:1736:87: Note [Lifecycle of a splice] ref compiler/GHC/Hs/Expr.hs:1772:7: Note [Pending Splices] @@ -15,6 +15,7 @@ ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constr ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/JS/Optimizer.hs:206:7: Note [Unsafe JavaScript optimizations] ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] ref compiler/GHC/StgToCmm.hs:106:18: Note [codegen-split-init] ref compiler/GHC/StgToCmm.hs:109:18: Note [pipeline-split-init] @@ -25,14 +26,14 @@ ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:357:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:532:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:656:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:889:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] ref compiler/GHC/Tc/Module.hs:711:15: Note [Extra dependencies from .hs-boot files] ref compiler/GHC/Tc/Solver/Rewrite.hs:1008:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1120:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/TyCl.hs:1124:6: Note [Unification variables need fresh Names] ref compiler/GHC/Tc/Types.hs:692:33: Note [Extra dependencies from .hs-boot files] ref compiler/GHC/Tc/Types.hs:1423:47: Note [Care with plugin imports] ref compiler/GHC/Tc/Types/Constraint.hs:255:34: Note [NonCanonical Semantics] @@ -46,8 +47,8 @@ ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threa ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ref linters/lint-notes/Notes.hs:69:22: Note [...] ref testsuite/config/ghc:272:10: Note [WayFlags] -ref testsuite/driver/testlib.py:160:10: Note [Why is there no stage1 setup function?] -ref testsuite/driver/testlib.py:164:2: Note [Why is there no stage1 setup function?] +ref testsuite/driver/testlib.py:165:10: Note [Why is there no stage1 setup function?] +ref testsuite/driver/testlib.py:169:2: Note [Why is there no stage1 setup function?] ref testsuite/mk/boilerplate.mk:267:2: Note [WayFlags] ref testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.hs:30:27: Note [Extra TcS Untouchables] ref testsuite/tests/perf/should_run/all.T:8:6: Note [Solving from instances when interacting Dicts] ===================================== testsuite/tests/th/T21050.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell, ImpredicativeTypes #-} +module T21050 where + +import Language.Haskell.TH.Syntax + +data T = MkT (forall a. a) + +f x = [|| MkT $$(x) ||] + +g :: Code Q (forall a. a) -> Code Q T +g x = [|| MkT $$(x) ||] ===================================== testsuite/tests/th/T21050.stderr ===================================== @@ -0,0 +1,26 @@ + +T21050.hs:8:18: error: [GHC-25897] + • Couldn't match expected type ‘Code m a1’ with actual type ‘p’ + ‘p’ is a rigid type variable bound by + the inferred type of f :: Quote m => p -> Code m T + at T21050.hs:8:1-23 + • In the expression: x + In the Template Haskell splice $$(x) + In the first argument of ‘MkT’, namely ‘$$(x)’ + • Relevant bindings include + x :: p (bound at T21050.hs:8:3) + f :: p -> Code m T (bound at T21050.hs:8:1) + +T21050.hs:11:18: error: [GHC-91028] + • Couldn't match type ‘a’ with ‘forall a2. a2’ + Expected: Code Q a + Actual: Code Q (forall a. a) + Cannot equate type variable ‘a’ + with a type involving polytypes: forall a2. a2 + ‘a’ is a rigid type variable bound by + a type expected by the context: + forall a. a + at T21050.hs:11:15-19 + • In the expression: x + In the Template Haskell splice $$(x) + In the first argument of ‘MkT’, namely ‘$$(x)’ ===================================== testsuite/tests/th/all.T ===================================== @@ -564,3 +564,4 @@ test('TH_typed2', normal, compile_and_run, ['']) test('TH_typed3', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_typed4', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_typed5', normal, compile_and_run, ['']) +test('T21050', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d412b16742d187ad3e3f3a97dc3e2954c2abbb49...d137ce9c9a8fbdac3105167fa039269b2c35e477 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d412b16742d187ad3e3f3a97dc3e2954c2abbb49...d137ce9c9a8fbdac3105167fa039269b2c35e477 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 23:20:58 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Tue, 09 May 2023 19:20:58 -0400 Subject: [Git][ghc/ghc][wip/orig-thunk-info] 8 commits: testsuite: Add test for atomicSwapIORef Message-ID: <645ad55a88fb3_38ffdadbd4ac5c143283b@gitlab.mail> Ben Gamari pushed to branch wip/orig-thunk-info at Glasgow Haskell Compiler / GHC Commits: b970e64f by Ben Gamari at 2023-05-09T08:41:33-04:00 testsuite: Add test for atomicSwapIORef - - - - - 81cfefd2 by Ben Gamari at 2023-05-09T08:41:53-04:00 compiler: Implement atomicSwapIORef with xchg As requested by @treeowl in CLC#139. - - - - - 6b29154d by Ben Gamari at 2023-05-09T08:41:53-04:00 Make atomicSwapMutVar# an inline primop - - - - - 64064cfe by doyougnu at 2023-05-09T18:40:01-04:00 JS: add GHC.JS.Optimizer, remove RTS.Printer, add Linker.Opt This MR changes some simple optimizations and is a first step in re-architecting the JS backend pipeline to add the optimizer. In particular it: - removes simple peep hole optimizations from `GHC.StgToJS.Printer` and removes that module - adds module `GHC.JS.Optimizer` - defines the same peep hole opts that were removed only now they are `Syntax -> Syntax` transformations rather than `Syntax -> JS code` optimizations - hooks the optimizer into code gen - adds FuncStat and ForStat constructors to the backend. Working Ticket: - #22736 Related MRs: - MR !10142 - MR !10000 ------------------------- Metric Decrease: CoOpt_Read ManyAlternatives PmSeriesS PmSeriesT PmSeriesV T10421 T12707 T13253 T13253-spj T15164 T17516 T18140 T18282 T18698a T18698b T18923 T1969 T19695 T20049 T3064 T5321FD T5321Fun T783 T9198 T9233 T9630 ------------------------- - - - - - 6738c01d by Krzysztof Gogolewski at 2023-05-09T18:40:38-04:00 Add a regression test for #21050 - - - - - b2cdb7da by Ben Gamari at 2023-05-09T18:41:14-04:00 nonmoving: Account for mutator allocations in bytes_allocated Previously we failed to account direct mutator allocations into the nonmoving heap against the mutator's allocation limit and `cap->total_allocated`. This only manifests during CAF evaluation (since we allocate the CAF's blackhole directly into the nonmoving heap). Fixes #23312. - - - - - 428734fc by Ben Gamari at 2023-05-09T19:20:47-04:00 compiler: Fingerprint more code generation flags Previously our recompilation check was quite inconsistent in its coverage of non-optimisation code generation flags. Specifically, we failed to account for most flags that would affect the behavior of generated code in ways that might affect the result of a program's execution (e.g. `-feager-blackholing`, `-fstrict-dicts`) Closes #23369. - - - - - 40f8200e by Ben Gamari at 2023-05-09T19:20:54-04:00 compiler: Record original thunk info tables on stack - - - - - 30 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Recomp/Flags.hs - compiler/GHC/JS/Make.hs - + compiler/GHC/JS/Optimizer.hs - compiler/GHC/JS/Ppr.hs - compiler/GHC/JS/Syntax.hs - compiler/GHC/JS/Transform.hs - compiler/GHC/JS/Unsat/Syntax.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/CodeGen.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/StgToJS/Printer.hs → compiler/GHC/StgToJS/Linker/Opt.hs - compiler/GHC/StgToJS/Object.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Rts/Rts.hs - compiler/ghc.cabal.in - docs/users_guide/debugging.rst - libraries/base/GHC/IORef.hs - + libraries/base/tests/AtomicSwapIORef.hs - + libraries/base/tests/AtomicSwapIORef.stdout - libraries/base/tests/all.T - rts/StgMiscClosures.cmm The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d32cad7947b22dd753200dbce82039ea86db794...40f8200ee17575021c336c0aba14b684980415dc -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d32cad7947b22dd753200dbce82039ea86db794...40f8200ee17575021c336c0aba14b684980415dc You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 23:28:18 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Tue, 09 May 2023 19:28:18 -0400 Subject: [Git][ghc/ghc][wip/romes/linear-core] 90 commits: rts: improve memory ordering and add some comments in the StablePtr implementation Message-ID: <645ad712e457c_38ffdadcbf83e4143635c@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/linear-core at Glasgow Haskell Compiler / GHC Commits: a34aa8da by Adam Sandberg Ericsson at 2023-04-14T04:17:52-04:00 rts: improve memory ordering and add some comments in the StablePtr implementation - - - - - d7a768a4 by Matthew Pickering at 2023-04-14T04:18:28-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 - - - - - d48fbfea by Simon Peyton Jones at 2023-04-14T04:19:05-04:00 Stop if type constructors have kind errors Otherwise we get knock-on errors, such as #23252. This makes GHC fail a bit sooner, and I have not attempted to add recovery code, to add a fake TyCon place of the erroneous one, in an attempt to get more type errors in one pass. We could do that (perhaps) if there was a call for it. - - - - - 2371d6b2 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Major refactor in the handling of equality constraints This MR substantially refactors the way in which the constraint solver deals with equality constraints. The big thing is: * Intead of a pipeline in which we /first/ canonicalise and /then/ interact (the latter including performing unification) the two steps are more closely integreated into one. That avoids the current rather indirect communication between the two steps. The proximate cause for this refactoring is fixing #22194, which involve solving [W] alpha[2] ~ Maybe (F beta[4]) by doing this: alpha[2] := Maybe delta[2] [W] delta[2] ~ F beta[4] That is, we don't promote beta[4]! This is very like introducing a cycle breaker, and was very awkward to do before, but now it is all nice. See GHC.Tc.Utils.Unify Note [Promotion and level-checking] and Note [Family applications in canonical constraints]. The big change is this: * Several canonicalisation checks (occurs-check, cycle-breaking, checking for concreteness) are combined into one new function: GHC.Tc.Utils.Unify.checkTyEqRhs This function is controlled by `TyEqFlags`, which says what to do for foralls, type families etc. * `canEqCanLHSFinish` now sees if unification is possible, and if so, actually does it: see `canEqCanLHSFinish_try_unification`. There are loads of smaller changes: * The on-the-fly unifier `GHC.Tc.Utils.Unify.unifyType` has a cheap-and-cheerful version of `checkTyEqRhs`, called `simpleUnifyCheck`. If `simpleUnifyCheck` succeeds, it can unify, otherwise it defers by emitting a constraint. This is simpler than before. * I simplified the swapping code in `GHC.Tc.Solver.Equality.canEqCanLHS`. Especially the nasty stuff involving `swap_for_occurs` and `canEqTyVarFunEq`. Much nicer now. See Note [Orienting TyVarLHS/TyFamLHS] Note [Orienting TyFamLHS/TyFamLHS] * Added `cteSkolemOccurs`, `cteConcrete`, and `cteCoercionHole` to the problems that can be discovered by `checkTyEqRhs`. * I fixed #23199 `pickQuantifiablePreds`, which actually allows GHC to to accept both cases in #22194 rather than rejecting both. Yet smaller: * Added a `synIsConcrete` flag to `SynonymTyCon` (alongside `synIsFamFree`) to reduce the need for synonym expansion when checking concreteness. Use it in `isConcreteType`. * Renamed `isConcrete` to `isConcreteType` * Defined `GHC.Core.TyCo.FVs.isInjectiveInType` as a more efficient way to find if a particular type variable is used injectively than finding all the injective variables. It is called in `GHC.Tc.Utils.Unify.definitely_poly`, which in turn is used quite a lot. * Moved `rewriterView` to `GHC.Core.Type`, so we can use it from the constraint solver. Fixes #22194, #23199 Compile times decrease by an average of 0.1%; but there is a 7.4% drop in compiler allocation on T15703. Metric Decrease: T15703 - - - - - 99b2734b by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Add some documentation about redundant constraints - - - - - 3f2d0eb8 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Improve partial signatures This MR fixes #23223. The changes are in two places: * GHC.Tc.Bind.checkMonomorphismRestriction See the new `Note [When the MR applies]` We now no longer stupidly attempt to apply the MR when the user specifies a context, e.g. f :: Eq a => _ -> _ * GHC.Tc.Solver.decideQuantification See rewritten `Note [Constraints in partial type signatures]` Fixing this bug apparently breaks three tests: * partial-sigs/should_compile/T11192 * partial-sigs/should_fail/Defaulting1MROff * partial-sigs/should_fail/T11122 However they are all symptoms of #23232, so I'm marking them as expect_broken(23232). I feel happy about this MR. Nice. - - - - - 23e2a8a0 by Simon Peyton Jones at 2023-04-14T20:01:02+02:00 Make approximateWC a bit cleverer This MR fixes #23224: making approximateWC more clever See the long `Note [ApproximateWC]` in GHC.Tc.Solver All this is delicate and ad-hoc -- but it /has/ to be: we are talking about inferring a type for a binding in the presence of GADTs, type families and whatnot: known difficult territory. We just try as hard as we can. - - - - - 2c040246 by Matthew Pickering at 2023-04-15T00:57:14-04:00 docs: Update template-haskell docs to use Code Q a rather than Q (TExp a) Since GHC Proposal #195, the type of [|| ... ||] has been Code Q a rather than Q (TExp a). The documentation in the `template-haskell` library wasn't updated to reflect this change. Fixes #23148 - - - - - 0da18eb7 by Krzysztof Gogolewski at 2023-04-15T14:35:53+02:00 Show an error when we cannot default a concrete tyvar Fixes #23153 - - - - - bad2f8b8 by sheaf at 2023-04-15T15:14:36+02:00 Handle ConcreteTvs in inferResultToType inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. Fixes #23154 - - - - - 3b0ea480 by Simon Peyton Jones at 2023-04-16T18:12:20-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 - - - - - a1371ebb by Oleg Grenrus at 2023-04-16T18:12:59-04:00 Add import lists to few GHC.Driver.Session imports Related to https://gitlab.haskell.org/ghc/ghc/-/issues/23261. There are a lot of GHC.Driver.Session which only use DynFlags, but not the parsing code. - - - - - 51479ceb by Matthew Pickering at 2023-04-17T08:08:48-04:00 Account for special GHC.Prim import in warnUnusedPackages The GHC.Prim import is treated quite specially primarily because there isn't an interface file for GHC.Prim. Therefore we record separately in the ModSummary if it's imported or not so we don't go looking for it. This logic hasn't made it's way to `-Wunused-packages` so if you imported GHC.Prim then the warning would complain you didn't use `-package ghc-prim`. Fixes #23212 - - - - - 1532a8b2 by Simon Peyton Jones at 2023-04-17T08:09:24-04:00 Add regression test for #23199 - - - - - 0158c5f1 by Ryan Scott at 2023-04-17T18:43:27-04:00 validDerivPred: Reject exotic constraints in IrredPreds This brings the `IrredPred` case in sync with the treatment of `ClassPred`s as described in `Note [Valid 'deriving' predicate]` in `GHC.Tc.Validity`. Namely, we should reject `IrredPred`s that are inferred from `deriving` clauses whose arguments contain other type constructors, as described in `(VD2) Reject exotic constraints` of that Note. This has the nice property that `deriving` clauses whose inferred instance context mention `TypeError` will now emit the type error in the resulting error message, which better matches existing intuitions about how `TypeError` should work. While I was in town, I noticed that much of `Note [Valid 'deriving' predicate]` was duplicated in a separate `Note [Exotic derived instance contexts]` in `GHC.Tc.Deriv.Infer`. I decided to fold the latter Note into the former so that there is a single authority on describing the conditions under which an inferred `deriving` constraint can be considered valid. This changes the behavior of `deriving` in a way that existing code might break, so I have made a mention of this in the GHC User's Guide. It seems very, very unlikely that much code is relying on this strange behavior, however, and even if there is, there is a clear, backwards-compatible migration path using `StandaloneDeriving`. Fixes #22696. - - - - - 10364818 by Krzysztof Gogolewski at 2023-04-17T18:44:03-04:00 Misc cleanup - Use dedicated list functions - Make cloneBndrs and cloneRecIdBndrs monadic - Fix invalid haddock comments in libraries/base - - - - - 5e1d33d7 by Matthew Pickering at 2023-04-18T10:31:02-04:00 Convert interface file loading errors into proper diagnostics This patch converts all the errors to do with loading interface files into proper structured diagnostics. * DriverMessage: Sometimes in the driver we attempt to load an interface file so we embed the IfaceMessage into the DriverMessage. * TcRnMessage: Most the time we are loading interface files during typechecking, so we embed the IfaceMessage This patch also removes the TcRnInterfaceLookupError constructor which is superceded by the IfaceMessage, which is now structured compared to just storing an SDoc before. - - - - - df1a5811 by sheaf at 2023-04-18T10:31:43-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 - - - - - d442ac05 by Sylvain Henry at 2023-04-19T20:04:35-04:00 JS: fix thread-related primops - - - - - 7a96f90b by Bryan Richter at 2023-04-19T20:05:11-04:00 CI: Disable abi-test-nightly See #23269 - - - - - ab6c1d29 by Sylvain Henry at 2023-04-19T20:05:50-04:00 Testsuite: don't use obsolescent egrep (#22351) Recent egrep displays the following message, breaking golden tests: egrep: warning: egrep is obsolescent; using grep -E Switch to using "grep -E" instead - - - - - f15b0ce5 by Matthew Pickering at 2023-04-20T11:01:06-04:00 hadrian: Pass haddock file arguments in a response file In !10119 CI was failing on windows because the command line was too long. We can mitigate this by passing the file arguments to haddock in a response file. We can't easily pass all the arguments in a response file because the `+RTS` arguments can't be placed in the response file. Fixes #23273 - - - - - 7012ec2f by tocic at 2023-04-20T11:01:42-04:00 Fix doc typo in GHC.Read.readList - - - - - 5c873124 by sheaf at 2023-04-20T18:33:34-04:00 Implement -jsem: parallelism controlled by semaphores See https://github.com/ghc-proposals/ghc-proposals/pull/540/ for a complete description for the motivation for this feature. The `-jsem` option allows a build tool to pass a semaphore to GHC which GHC can use in order to control how much parallelism it requests. GHC itself acts as a client in the GHC jobserver protocol. ``` GHC Jobserver Protocol ~~~~~~~~~~~~~~~~~~~~~~ This proposal introduces the GHC Jobserver Protocol. This protocol allows a server to dynamically invoke many instances of a client process, while restricting all of those instances to use no more than <n> capabilities. This is achieved by coordination over a system semaphore (either a POSIX semaphore [6]_ in the case of Linux and Darwin, or a Win32 semaphore [7]_ in the case of Windows platforms). There are two kinds of participants in the GHC Jobserver protocol: - The *jobserver* creates a system semaphore with a certain number of available tokens. Each time the jobserver wants to spawn a new jobclient subprocess, it **must** first acquire a single token from the semaphore, before spawning the subprocess. This token **must** be released once the subprocess terminates. Once work is finished, the jobserver **must** destroy the semaphore it created. - A *jobclient* is a subprocess spawned by the jobserver or another jobclient. Each jobclient starts with one available token (its *implicit token*, which was acquired by the parent which spawned it), and can request more tokens through the Jobserver Protocol by waiting on the semaphore. Each time a jobclient wants to spawn a new jobclient subprocess, it **must** pass on a single token to the child jobclient. This token can either be the jobclient's implicit token, or another token which the jobclient acquired from the semaphore. Each jobclient **must** release exactly as many tokens as it has acquired from the semaphore (this does not include the implicit tokens). ``` Build tools such as cabal act as jobservers in the protocol and are responsibile for correctly creating, cleaning up and managing the semaphore. Adds a new submodule (semaphore-compat) for managing and interacting with semaphores in a cross-platform way. Fixes #19349 - - - - - 52d3e9b4 by Ben Gamari at 2023-04-20T18:34:11-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 - - - - - 1db30fe1 by Ben Gamari at 2023-04-20T18:34:11-04:00 testsuite: Add test for #23071 - - - - - dae514f9 by tocic at 2023-04-21T13:31:21-04:00 Fix doc typos in libraries/base/GHC - - - - - 113e21d7 by Sylvain Henry at 2023-04-21T13:32:01-04:00 Testsuite: replace some js_broken/js_skip predicates with req_c Using req_c is more precise. - - - - - 038bb031 by Krzysztof Gogolewski at 2023-04-21T18:03:04-04:00 Minor doc fixes - Add docs/index.html to .gitignore. It is created by ./hadrian/build docs, and it was the only file in Hadrian's templateRules not present in .gitignore. - Mention that MultiWayIf supports non-boolean guards - Remove documentation of optdll - removed in 2007, 763daed95 - Fix markdown syntax - - - - - e826cdb2 by amesgen at 2023-04-21T18:03:44-04:00 User's guide: DeepSubsumption is implied by Haskell{98,2010} - - - - - 499a1c20 by PHO at 2023-04-23T13:39:32-04:00 Implement executablePath for Solaris and make getBaseDir less platform-dependent Use base-4.17 executablePath when possible, and fall back on getExecutablePath when it's not available. The sole reason why getBaseDir had #ifdef's was apparently that getExecutablePath wasn't reliable, and we could reduce the number of CPP conditionals by making use of executablePath instead. Also export executablePath on js_HOST_ARCH. - - - - - 97a6f7bc by tocic at 2023-04-23T13:40:08-04:00 Fix doc typos in libraries/base - - - - - 787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00 testsuite/T20137: Avoid impl.-defined behavior Previously we would cast pointers to uint64_t. However, implementations are allowed to either zero- or sign-extend such casts. Instead cast to uintptr_t to avoid this. Fixes #23247. - - - - - 87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00 rts: always build 64-bit atomic ops This patch does a few things: - Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit platforms - Remove legacy "64bit" cabal flag of rts package - Fix hs_xchg64 function prototype for 32-bit platforms - Fix AtomicFetch test for wasm32 - - - - - 2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00 compiler: don't install signal handlers when the host platform doesn't have signals Previously, large parts of GHC API will transitively invoke withSignalHandlers, which doesn't work on host platforms without signal functionality at all (e.g. wasm32-wasi). By making withSignalHandlers a no-op on those platforms, we can make more parts of GHC API work out of the box when signals aren't supported. - - - - - 1338b7a3 by Cheng Shao at 2023-04-24T16:21:30-04:00 hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC - - - - - 1a10f556 by Bodigrim at 2023-04-24T16:22:09-04:00 Add since pragma to Data.Functor.unzip - - - - - 0da9e882 by Soham Chowdhury at 2023-04-25T00:15:22-04:00 More informative errors for bad imports (#21826) - - - - - ebd5b078 by Josh Meredith at 2023-04-25T00:15:58-04:00 JS/base: provide implementation for mkdir (issue 22374) - - - - - 8f656188 by Josh Meredith at 2023-04-25T18:12:38-04:00 JS: Fix h$base_access implementation (issue 22576) - - - - - 74c55712 by Andrei Borzenkov at 2023-04-25T18:13:19-04:00 Give more guarntees about ImplicitParams (#23289) - Added new section in the GHC user's guide that legends behavior of nested implicit parameter bindings in these two cases: let ?f = 1 in let ?f = 2 in ?f and data T where MkT :: (?f :: Int) => T f :: T -> T -> Int f MkT MkT = ?f - Added new test case to examine this behavior. - - - - - c30ac25f by Sebastian Graf at 2023-04-26T14:50:51-04:00 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. - - - - - 77f506b8 by Josh Meredith at 2023-04-26T14:51:28-04:00 Refactor GenStgRhs to include the Type in both constructors (#23280, #22576, #22364) Carry the actual type of an expression through the PreStgRhs and into GenStgRhs for use in later stages. Currently this is used in the JavaScript backend to fix some tests from the above mentioned issues: EtaExpandLevPoly, RepPolyWrappedVar2, T13822, T14749. - - - - - 052e2bb6 by Alan Zimmerman at 2023-04-26T14:52:05-04:00 EPA: Use ExplicitBraces only in HsModule !9018 brought in exact print annotations in LayoutInfo for open and close braces at the top level. But it retained them in the HsModule annotations too. Remove the originals, so exact printing uses LayoutInfo - - - - - d5c4629b by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: update ci.sh to actually run the entire testsuite for wasm backend For the time being, we still need to use in-tree mode and can't test the bindist yet. - - - - - 533d075e by Cheng Shao at 2023-04-27T16:00:35-04:00 ci: additional wasm32 manual jobs in validate pipelines This patch enables bignum native & unregisterised wasm32 jobs as manual jobs in validate pipelines, which can be useful to prevent breakage when working on wasm32 related patches. - - - - - b5f00811 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix cross prefix stripping This patch fixes cross prefix stripping in the testsuite driver. The normalization logic used to only handle prefixes of the triple form <arch>-<vendor>-<os>, now it's relaxed to allow any number of tokens in the prefix tuple, so the cross prefix stripping logic would work when ghc is configured with something like --target=wasm32-wasi. - - - - - 6f511c36 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: include target exe extension in heap profile filenames This patch fixes hp2ps related framework failures when testing the wasm backend by including target exe extension in heap profile filenames. - - - - - e6416b10 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: exclude ghci ways if no rts linker is present This patch implements logic to automatically exclude ghci ways when there is no rts linker. It's way better than having to annotate individual test cases. - - - - - 791cce64 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: fix permission bits in copy_files When the testsuite driver copy files instead of symlinking them, it should also copy the permission bits, otherwise there'll be permission denied errors. Also, enforce file copying when testing wasm32, since wasmtime doesn't handle host symlinks quite well (https://github.com/bytecodealliance/wasmtime/issues/6227). - - - - - aa6afe8a by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_ghc_with_threaded_rts predicate This patch adds the req_ghc_with_threaded_rts predicate to the testsuite to assert the platform has threaded RTS, and mark some tests as req_ghc_with_threaded_rts. Also makes ghc_with_threaded_rts a config field instead of a global variable. - - - - - ce580426 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_process predicate This patch adds the req_process predicate to the testsuite to assert the platform has a process model, also marking tests that involve spawning processes as req_process. Also bumps hpc & process submodule. - - - - - cb933665 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add the req_host_target_ghc predicate This patch adds the req_host_target_ghc predicate to the testsuite to assert the ghc compiler being tested can compile both host/target code. When testing cross GHCs this is not supported yet, but it may change in the future. - - - - - b174a110 by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: add missing annotations for some tests This patch adds missing annotations (req_th, req_dynamic_lib_support, req_rts_linker) to some tests. They were discovered when testing wasm32, though it's better to be explicit about what features they require, rather than simply adding when(arch('wasm32'), skip). - - - - - bd2bfdec by Cheng Shao at 2023-04-27T16:00:35-04:00 testsuite: wasm32-specific fixes This patch includes all wasm32-specific testsuite fixes. - - - - - 4eaf2c2a by Josh Meredith at 2023-04-27T16:01:11-04:00 JS: change GHC.JS.Transform.identsS/E/V to take a saturated IR (#23304) - - - - - 57277662 by sheaf at 2023-04-29T20:23:06+02:00 Add the Unsatisfiable class This commit implements GHC proposal #433, adding the Unsatisfiable class to the GHC.TypeError module. This provides an alternative to TypeError for which error reporting is more predictable: we report it when we are reporting unsolved Wanted constraints. Fixes #14983 #16249 #16906 #18310 #20835 - - - - - 00a8a5ff by Torsten Schmits at 2023-04-30T03:45:09-04:00 Add structured error messages for GHC.Rename.Names Tracking ticket: #20115 MR: !10336 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 931c8d82 by Ben Orchard at 2023-05-03T20:16:18-04:00 Add sized primitive literal syntax Adds a new LANGUAGE pragma ExtendedLiterals, which enables defining unboxed numeric literals such as `0xFF#Word8 :: Word8#`. Implements GHC proposal 0451: https://github.com/ghc-proposals/ghc-proposals/blob/b384a538b34f79d18a0201455b7b3c473bc8c936/proposals/0451-sized-literals.rst Fixes #21422. Bumps haddock submodule. Co-authored-by: Krzysztof Gogolewski <krzysztof.gogolewski at tweag.io> - - - - - f3460845 by Bodigrim at 2023-05-03T20:16:57-04:00 Document instances of Double - - - - - 1e9caa1a by Sylvain Henry at 2023-05-03T20:17:37-04:00 Bump Cabal submodule (#22356) - - - - - 4eafb52a by sheaf at 2023-05-03T20:18:16-04:00 Don't forget to check the parent in an export list Commit 3f374399 introduced a bug which caused us to forget to include the parent of an export item of the form T(..) (that is, IEThingAll) when checking for duplicate exports. Fixes #23318 - - - - - 8fde4ac8 by amesgen at 2023-05-03T20:18:57-04:00 Fix unlit path in cross bindists - - - - - 8cc9a534 by Matthew Pickering at 2023-05-04T14:58:14-04:00 hadrian: Flavour: Change args -> extraArgs Previously in a flavour definition you could override all the flags which were passed to GHC. This causes issues when needed to compute a package hash because we need to know what these extra arguments are going to be before computing the hash. The solution is to modify flavour so that the arguments you pass here are just extra ones rather than all the arguments that you need to compile something. This makes things work more like how cabal.project files work when you give extra arguments to a package and also means that flavour transformers correctly affect the hash. - - - - - 3fdb18f8 by romes at 2023-05-04T14:58:14-04:00 Hardwire a better unit-id for ghc Previously, the unit-id of ghc-the-library was fixed as `ghc`. This was done primarily because the compiler must know the unit-id of some packages (including ghc) a-priori to define wired-in names. However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed to `ghc` might result in subtle bugs when different ghc's interact. A good example of this is having GHC_A load a plugin compiled by GHC_B, where GHC_A and GHC_B are linked to ghc-libraries that are ABI incompatible. Without a distinction between the unit-id of the ghc library GHC_A is linked against and the ghc library the plugin it is loading was compiled against, we can't check compatibility. This patch gives a slightly better unit-id to ghc (ghc-version) by (1) Not setting -this-unit-id to ghc, but rather to the new unit-id (modulo stage0) (2) Adding a definition to `GHC.Settings.Config` whose value is the new unit-id. (2.1) `GHC.Settings.Config` is generated by Hadrian (2.2) and also by cabal through `compiler/Setup.hs` This unit-id definition is imported by `GHC.Unit.Types` and used to set the wired-in unit-id of "ghc", which was previously fixed to "ghc" The commits following this one will improve the unit-id with a cabal-style package hash and check compatibility when loading plugins. Note that we also ensure that ghc's unit key matches unit id both when hadrian or cabal builds ghc, and in this way we no longer need to add `ghc` to the WiringMap. - - - - - 6689c9c6 by romes at 2023-05-04T14:58:14-04:00 Validate compatibility of ghcs when loading plugins Ensure, when loading plugins, that the ghc the plugin depends on is the ghc loading the plugin -- otherwise fail to load the plugin. Progress towards #20742. - - - - - db4be339 by romes at 2023-05-04T14:58:14-04:00 Add hashes to unit-ids created by hadrian This commit adds support for computing an inputs hash for packages compiled by hadrian. The result is that ABI incompatible packages should be given different hashes and therefore be distinct in a cabal store. Hashing is enabled by the `--flag`, and is off by default as the hash contains a hash of the source files. We enable it when we produce release builds so that the artifacts we distribute have the right unit ids. - - - - - 944a9b94 by Matthew Pickering at 2023-05-04T14:58:14-04:00 Use hash-unit-ids in release jobs Includes fix upload_ghc_libs glob - - - - - 116d7312 by Josh Meredith at 2023-05-04T14:58:51-04:00 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. - - - - - 2d5c1dde by Sylvain Henry at 2023-05-04T14:58:51-04:00 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. - - - - - 98c5ee45 by Luite Stegeman at 2023-05-04T14:59:31-04:00 JavaScript: Correct arguments to h$appendToHsStringA fixes #23278 - - - - - ca611447 by Josh Meredith at 2023-05-04T15:00:07-04:00 base/encoding: add an allocations performance test (#22946) - - - - - e3ddf58d by Krzysztof Gogolewski at 2023-05-04T15:00:44-04:00 linear types: Don't add external names to the usage env This has no observable effect, but avoids storing useless data. - - - - - b3226616 by Andrei Borzenkov at 2023-05-04T15:01:25-04:00 Improved documentation for the Data.OldList.nub function There was recomentation to use map head . group . sort instead of nub function, but containers library has more suitable and efficient analogue - - - - - e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. - - - - - 275836d2 by Torsten Schmits at 2023-05-05T08:43:02+00:00 Add structured error messages for GHC.Rename.Utils Tracking ticket: #20115 MR: !10350 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 983ce558 by Oleg Grenrus at 2023-05-05T13:11:29-04:00 Use TemplateHaskellQuotes in TH.Syntax to construct Names - - - - - a5174a59 by Matthew Pickering at 2023-05-05T18:42:31-04:00 driver: Use hooks from plugin_hsc_env This fixes a bug in oneshot mode where hooks modified in a plugin wouldn't be used in oneshot mode because we neglected to use the right hsc_env. This was observed by @csabahruska. - - - - - 18a7d03d by Aaron Allen at 2023-05-05T18:42:31-04:00 Rework plugin initialisation points In general this patch pushes plugin initialisation points to earlier in the pipeline. As plugins can modify the `HscEnv`, it's imperative that the plugins are initialised as soon as possible and used thereafter. For example, there are some new tests which modify hsc_logger and other hooks which failed to fire before (and now do) One consequence of this change is that the error for specifying the usage of a HPT plugin from the command line has changed, because it's now attempted to be loaded at initialisation rather than causing a cyclic module import. Closes #21279 Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com> - - - - - 6e776ed3 by Matthew Pickering at 2023-05-05T18:42:31-04:00 docs: Add Note [Timing of plugin initialization] - - - - - e1df8511 by Matthew Pickering at 2023-05-05T18:43:07-04:00 Incrementally update ghcup metadata in ghc/ghcup-metadata This job paves the way for distributing nightly builds * A new repo https://gitlab.haskell.org/ghc/ghcup-metadata stores the metadata on the "updates" branch. * Each night this metadata is downloaded and the nightly builds are appended to the end of the metadata. * The update job only runs on the scheduled nightly pipeline, not just when NIGHTLY=1. Things which are not done yet * Modify the retention policy for nightly jobs * Think about building release flavour compilers to distribute nightly. Fixes #23334 - - - - - 8f303d27 by Rodrigo Mesquita at 2023-05-05T22:04:31-04:00 docs: Remove mentions of ArrayArray# from unlifted FFI section Fixes #23277 - - - - - 994bda56 by Torsten Schmits at 2023-05-05T22:05:12-04:00 Add structured error messages for GHC.Rename.Module Tracking ticket: #20115 MR: !10361 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. Only addresses the single warning missing from the previous MR. - - - - - 3e3a6be4 by Ben Gamari at 2023-05-08T12:15:19+00:00 rts: Fix data-race in hs_init_ghc As noticed by @Terrorjack, `hs_init_ghc` previously used non-atomic increment/decrement on the RTS's initialization count. This may go wrong in a multithreaded program which initializes the runtime multiple times. Closes #22756. - - - - - 78c8dc50 by Torsten Schmits at 2023-05-08T21:41:51-04:00 Add structured error messages for GHC.IfaceToCore Tracking ticket: #20114 MR: !10390 This converts uses of `mkTcRnUnknownMessage` to newly added constructors of `TcRnMessage`. - - - - - 0e2df4c9 by Bryan Richter at 2023-05-09T12:03:35+03:00 Fix up rules for ghcup-metadata-nightly-push - - - - - d2744218 by Rodrigo Mesquita at 2023-05-09T21:11:27+01:00 WIP: Anotate provenance and mult or usageenv - - - - - 1abcc625 by Rodrigo Mesquita at 2023-05-09T21:11:29+01:00 More fixes, in particular in bindNonRec... In bindNonRec make sure if we return a case instead of a let we make the idBinding correct - - - - - 3ed87df0 by Rodrigo Mesquita at 2023-05-09T21:11:29+01:00 Lint binding site matches id binding - - - - - 8fbb2acf by Rodrigo Mesquita at 2023-05-10T00:25:54+01:00 ROMES: WIP improvements In particular, we note that in dsUnliftedBind we pass to matchEquations variables which were let bound, which get further down the line used in matchOneConLike (and in bindNonRec too) as case-pattern bound variables! In this situation, where we use originally let-bound variables as case bound variables, we must ensure the case bound variables are set to be `LambdaBound` with the correct multiplicity (which should be some mix of scaling with the constructor annotated multiplicities) TODO: The multiplicity corresponding to the constructor multiplicity scaled by ... - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/upload_ghc_libs.py - .gitmodules - cabal.project-reinstall - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82d4286bea775c525e5646e8f958aee4c17af607...8fbb2acf526295afdc873b44318c63a9def9026e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82d4286bea775c525e5646e8f958aee4c17af607...8fbb2acf526295afdc873b44318c63a9def9026e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue May 9 23:30:34 2023 From: gitlab at gitlab.haskell.org (Rodrigo Mesquita (@alt-romes)) Date: Tue, 09 May 2023 19:30:34 -0400 Subject: [Git][ghc/ghc][wip/romes/linear-core] ROMES: WIP improvements Message-ID: <645ad79a3ab2c_38ffdadd07208c14377c8@gitlab.mail> Rodrigo Mesquita pushed to branch wip/romes/linear-core at Glasgow Haskell Compiler / GHC Commits: 070f7fc1 by Rodrigo Mesquita at 2023-05-10T00:29:24+01:00 ROMES: WIP improvements In particular, we note that in dsUnliftedBind we pass to matchEquations variables which were let bound, which get further down the line used in matchOneConLike (and in bindNonRec too) as case-pattern bound variables! In this situation, where we use originally let-bound variables as case bound variables, we must ensure the case bound variables are set to be `LambdaBound` with the correct multiplicity (which should be some mix of scaling with the constructor annotated multiplicities) TODO: The multiplicity corresponding to the constructor multiplicity scaled by ... This broke through one more wall in the compilation of stage1 caused by incorrect provenences (well, really, by variables being moved around binding types while the provenence isn't updated) - - - - - 19 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match.hs-boot - compiler/GHC/HsToCore/Match/Constructor.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Var.hs - compiler/GHC/Utils/Outputable.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs, StandaloneDeriving #-} -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core ( @@ -270,9 +271,12 @@ type Arg b = Expr b -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in GHC.Core.Lint -data Alt b - = Alt AltCon [b] (Expr b) - deriving (Data) +-- data Alt b +-- = Alt AltCon [b] (Expr b) +-- deriving (Data) +data Alt b where + Alt :: HasCallStack => AltCon -> [b] -> (Expr b) -> Alt b +deriving instance Data b => Data (Alt b) -- | A case alternative constructor (i.e. pattern match) @@ -2204,7 +2208,7 @@ data AnnExpr' bndr annot | AnnCoercion Coercion -- | A clone of the 'Alt' type but allowing annotation at every tree node -data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot) +data AnnAlt bndr annot = HasCallStack => AnnAlt AltCon [bndr] (AnnExpr bndr annot) -- | A clone of the 'Bind' type but allowing annotation at every tree node data AnnBind bndr annot ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1693,7 +1693,7 @@ lintIdBndr top_lvl bind_site id thing_inside -- Check that the binding site matches the binding provenance of the id -- (we do this regardless of -dlinear-core-lint as it should always be true?) ; checkL (matchesBindingSite (idBinding id) bind_site) - (text "Core Id binding doesn't match binding site" <+> ppr (idBinding id) <+> ppr bind_site) + (text "Core Id binding doesn't match binding site" <+> ppr (idBinding id) <+> text (show bind_site)) -- Check that if the binder is nested, it is not marked as exported ; checkL (not (isExportedId id) || is_top_lvl) ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE GADTs #-} + -- | Handy functions for creating much Core syntax module GHC.Core.Make ( -- * Constructing normal syntax @@ -732,7 +734,7 @@ mkSmallTupleCase vars body scrut_var scrut data FloatBind = FloatLet CoreBind - | FloatCase CoreExpr Id AltCon [Var] + | HasCallStack => FloatCase CoreExpr Id AltCon [Var] -- case e of y { C ys -> ... } -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels @@ -741,7 +743,7 @@ instance Outputable FloatBind where ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b) 2 (ppr c <+> ppr bs) -wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat :: HasCallStack