[Git][ghc/ghc][wip/T24744] 8 commits: hadrian-ghci-multi: Pass -this-package-name in unit response files
Serge S. Gulin (@gulin.serge)
gitlab at gitlab.haskell.org
Mon Nov 25 17:39:03 UTC 2024
Serge S. Gulin pushed to branch wip/T24744 at Glasgow Haskell Compiler / GHC
Commits:
6e1fbda7 by Ben Gamari at 2024-11-25T03:55:44-05:00
hadrian-ghci-multi: Pass -this-package-name in unit response files
As noted in #25509, the `-this-package-name` must be passed for each
package to ensure that GHC can response references to the packages'
exposed modules via package-qualified imports. Fix this.
Closes #25509.
- - - - -
a05e4a9b by Simon Hengel at 2024-11-25T03:56:33-05:00
Refactoring: Use `OnOff` more consistently for `Extension`
- - - - -
88575a4d by Serge S. Gulin at 2024-11-25T20:38:36+03:00
Basic cleanup
- - - - -
23566ce7 by Serge S. Gulin at 2024-11-25T20:38:36+03:00
Add trivial optimizations for `unpackCString` and `unpackCStringUtf8`
- - - - -
cdedc572 by Serge S. Gulin at 2024-11-25T20:38:36+03:00
Enable static args
- - - - -
46aafb1a by Serge S. Gulin at 2024-11-25T20:38:36+03:00
Alternate way "Enable static args"
- - - - -
6828c3d2 by Serge S. Gulin at 2024-11-25T20:38:36+03:00
Alternate way "Enable static args"
- - - - -
b3691a29 by Serge S. Gulin at 2024-11-25T20:38:36+03:00
Remove useless premature optimization
- - - - -
16 changed files:
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Monad.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Symbols.hs
- compiler/GHC/StgToJS/Types.hs
- compiler/GHC/Types/Hint/Ppr.hs
- hadrian/src/Rules/ToolArgs.hs
- rts/js/string.js
Changes:
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -729,16 +729,6 @@ newtype FlushOut = FlushOut (IO ())
defaultFlushOut :: FlushOut
defaultFlushOut = FlushOut $ hFlush stdout
-
-
-data OnOff a = On a
- | Off a
- deriving (Eq, Show)
-
-instance Outputable a => Outputable (OnOff a) where
- ppr (On x) = text "On" <+> ppr x
- ppr (Off x) = text "Off" <+> ppr x
-
-- OnOffs accumulate in reverse order, so we use foldr in order to
-- process them in the right order
flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Driver.Flags
, minusWcompatOpts
, unusedBindsFlags
+ , OnOff(..)
, TurnOnFlag
, turnOn
, turnOff
@@ -77,6 +78,14 @@ instance Binary Language where
instance NFData Language where
rnf x = x `seq` ()
+data OnOff a = On a
+ | Off a
+ deriving (Eq, Show)
+
+instance Outputable a => Outputable (OnOff a) where
+ ppr (On x) = text "On" <+> ppr x
+ ppr (Off x) = text "Off" <+> ppr x
+
type TurnOnFlag = Bool -- True <=> we are turning the flag on
-- False <=> we are turning the flag off
turnOn :: TurnOnFlag; turnOn = True
@@ -269,78 +278,77 @@ extensionNames ext = mk (extensionDeprecation ext) (extensionName ext : exte
++ mk (ExtensionDeprecatedFor [ext]) (extensionDeprecatedNames ext)
where mk depr = map (\name -> (depr, name))
-
-impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
+impliedXFlags :: [(LangExt.Extension, OnOff LangExt.Extension)]
impliedXFlags
-- See Note [Updating flag description in the User's Guide]
- = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll)
- , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll)
- , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll)
- , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll)
- , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)
- , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances)
- , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses)
- , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854
- , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies)
+ = [ (LangExt.RankNTypes, On LangExt.ExplicitForAll)
+ , (LangExt.QuantifiedConstraints, On LangExt.ExplicitForAll)
+ , (LangExt.ScopedTypeVariables, On LangExt.ExplicitForAll)
+ , (LangExt.LiberalTypeSynonyms, On LangExt.ExplicitForAll)
+ , (LangExt.ExistentialQuantification, On LangExt.ExplicitForAll)
+ , (LangExt.FlexibleInstances, On LangExt.TypeSynonymInstances)
+ , (LangExt.FunctionalDependencies, On LangExt.MultiParamTypeClasses)
+ , (LangExt.MultiParamTypeClasses, On LangExt.ConstrainedClassMethods) -- c.f. #7854
+ , (LangExt.TypeFamilyDependencies, On LangExt.TypeFamilies)
- , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off!
+ , (LangExt.RebindableSyntax, Off LangExt.ImplicitPrelude) -- NB: turn off!
- , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)
+ , (LangExt.DerivingVia, On LangExt.DerivingStrategies)
- , (LangExt.GADTs, turnOn, LangExt.GADTSyntax)
- , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds)
- , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds)
+ , (LangExt.GADTs, On LangExt.GADTSyntax)
+ , (LangExt.GADTs, On LangExt.MonoLocalBinds)
+ , (LangExt.TypeFamilies, On LangExt.MonoLocalBinds)
- , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures
- , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds
+ , (LangExt.TypeFamilies, On LangExt.KindSignatures) -- Type families use kind signatures
+ , (LangExt.PolyKinds, On LangExt.KindSignatures) -- Ditto polymorphic kinds
-- TypeInType is now just a synonym for a couple of other extensions.
- , (LangExt.TypeInType, turnOn, LangExt.DataKinds)
- , (LangExt.TypeInType, turnOn, LangExt.PolyKinds)
- , (LangExt.TypeInType, turnOn, LangExt.KindSignatures)
+ , (LangExt.TypeInType, On LangExt.DataKinds)
+ , (LangExt.TypeInType, On LangExt.PolyKinds)
+ , (LangExt.TypeInType, On LangExt.KindSignatures)
-- Standalone kind signatures are a replacement for CUSKs.
- , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)
+ , (LangExt.StandaloneKindSignatures, Off LangExt.CUSKs)
-- AutoDeriveTypeable is not very useful without DeriveDataTypeable
- , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)
+ , (LangExt.AutoDeriveTypeable, On LangExt.DeriveDataTypeable)
-- We turn this on so that we can export associated type
-- type synonyms in subordinates (e.g. MyClass(type AssocType))
- , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces)
- , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)
+ , (LangExt.TypeFamilies, On LangExt.ExplicitNamespaces)
+ , (LangExt.TypeOperators, On LangExt.ExplicitNamespaces)
- , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes)
+ , (LangExt.ImpredicativeTypes, On LangExt.RankNTypes)
-- Record wild-cards implies field disambiguation
-- Otherwise if you write (C {..}) you may well get
-- stuff like " 'a' not in scope ", which is a bit silly
-- if the compiler has just filled in field 'a' of constructor 'C'
- , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields)
+ , (LangExt.RecordWildCards, On LangExt.DisambiguateRecordFields)
- , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp)
+ , (LangExt.ParallelArrays, On LangExt.ParallelListComp)
- , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)
+ , (LangExt.JavaScriptFFI, On LangExt.InterruptibleFFI)
- , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)
- , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)
+ , (LangExt.DeriveTraversable, On LangExt.DeriveFunctor)
+ , (LangExt.DeriveTraversable, On LangExt.DeriveFoldable)
-- Duplicate record fields require field disambiguation
- , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)
+ , (LangExt.DuplicateRecordFields, On LangExt.DisambiguateRecordFields)
- , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)
- , (LangExt.Strict, turnOn, LangExt.StrictData)
+ , (LangExt.TemplateHaskell, On LangExt.TemplateHaskellQuotes)
+ , (LangExt.Strict, On LangExt.StrictData)
-- Historically only UnboxedTuples was required for unboxed sums to work.
-- To avoid breaking code, we make UnboxedTuples imply UnboxedSums.
- , (LangExt.UnboxedTuples, turnOn, LangExt.UnboxedSums)
+ , (LangExt.UnboxedTuples, On LangExt.UnboxedSums)
-- The extensions needed to declare an H98 unlifted data type
- , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)
- , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)
+ , (LangExt.UnliftedDatatypes, On LangExt.DataKinds)
+ , (LangExt.UnliftedDatatypes, On LangExt.StandaloneKindSignatures)
-- See Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind
- , (LangExt.LinearTypes, turnOn, LangExt.MonoLocalBinds)
+ , (LangExt.LinearTypes, On LangExt.MonoLocalBinds)
]
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2925,13 +2925,18 @@ unSetExtensionFlag f = upd (unSetExtensionFlag' f)
setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags
setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps
where
- deps = [ if turn_on then setExtensionFlag' d
- else unSetExtensionFlag' d
- | (f', turn_on, d) <- impliedXFlags, f' == f ]
+ deps :: [DynFlags -> DynFlags]
+ deps = [ setExtension d
+ | (f', d) <- impliedXFlags, f' == f ]
-- When you set f, set the ones it implies
-- NB: use setExtensionFlag recursively, in case the implied flags
-- implies further flags
+ setExtension :: OnOff LangExt.Extension -> DynFlags -> DynFlags
+ setExtension = \ case
+ On extension -> setExtensionFlag' extension
+ Off extension -> unSetExtensionFlag' extension
+
unSetExtensionFlag' f dflags = xopt_unset dflags f
-- When you un-set f, however, we don't un-set the things it implies
-- (except for -fno-glasgow-exts, which is treated specially)
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -100,25 +100,6 @@ genApp
-> [StgArg]
-> G (JStgStat, ExprResult)
genApp ctx i args
- -- Test case T23479_2
- -- See: https://github.com/ghcjs/ghcjs/blob/b7711fbca7c3f43a61f1dba526e6f2a2656ef44c/src/Gen2/Generator.hs#L876
- -- Comment by Luite Stegeman <luite.stegeman at iohk.io>
- -- Special cases for JSString literals.
- -- We could handle unpackNBytes# here, but that's probably not common
- -- enough to warrant a special case.
- -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588/#note_503978
- -- Comment by Jeffrey Young <jeffrey.young at iohk.io>
- -- We detect if the Id is unsafeUnpackJSStringUtf8## applied to a string literal,
- -- if so then we convert the unsafeUnpack to a call to h$decode.
- | [StgVarArg v] <- args
- , idName i == unsafeUnpackJSStringUtf8ShShName
- -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588
- -- Comment by Josh Meredith <josh.meredith at iohk.io>
- -- `typex_expr` can throw an error for certain bindings so it's important
- -- that this condition comes after matching on the function name
- , [top] <- concatMap typex_expr (ctxTarget ctx)
- = (,ExprInline) . (|=) top . app hdDecodeUtf8Z <$> varsForId v
-
-- Test case T23479_1
| [StgLitArg (LitString bs)] <- args
, Just d <- decodeModifiedUTF8 bs
@@ -157,6 +138,24 @@ genApp ctx i args
, ExprInline
)
+ | [StgLitArg (LitString bs)] <- args
+ , Just d <- decodeModifiedUTF8 bs
+ , idName i == unpackCStringName
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = return
+ ( top |= app "h$toHsStringA" [toJExpr d]
+ , ExprInline
+ )
+
+ | [StgLitArg (LitString bs)] <- args
+ , Just d <- decodeModifiedUTF8 bs
+ , idName i == unpackCStringUtf8Name
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = return
+ ( top |= app "h$toHsString" [toJExpr d]
+ , ExprInline
+ )
+
-- let-no-escape
| Just n <- ctxLneBindingStackSize ctx i
= do
=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -22,9 +22,6 @@ module GHC.StgToJS.Arg
, genIdArgI
, genIdStackArgI
, allocConStatic
- , allocUnboxedConStatic
- , allocateStaticList
- , jsStaticArg
, jsStaticArgs
)
where
@@ -215,7 +212,7 @@ allocConStatic (identFS -> to) cc con args = do
emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc'
| otherwise = do
e <- identFS <$> identForDataConWorker con
- emitStatic to (StaticData e []) cc'
+ emitStatic to (StaticScalar $ StaticApp SAKData e []) cc'
allocConStatic' cc' [x]
| isUnboxableCon con =
case x of
@@ -234,7 +231,7 @@ allocConStatic (identFS -> to) cc con args = do
_ -> panic "allocConStatic: invalid args for consDataCon"
else do
e <- identFS <$> identForDataConWorker con
- emitStatic to (StaticData e xs) cc'
+ emitStatic to (StaticScalar $ StaticApp SAKData e xs) cc'
-- | Allocate unboxed constructors
allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -327,25 +327,26 @@ genToplevelRhs i rhs = case rhs of
eid <- identForEntryId i
idt <- identFS <$> identForId i
body <- genBody (initExprCtx i) R2 args body typ
- global_occs <- globalOccs body
+ lids <- globalOccs body
+ -- Regenerate idents from lids to restore right order of representatives.
+ -- Representatives have occurrence order which can be mixed.
+ lidents <- concat <$> traverse identsForId lids
let eidt = identFS eid
- let lidents = map global_ident global_occs
- let lids = map global_id global_occs
let lidents' = map identFS lidents
CIStaticRefs sr0 <- genStaticRefsRhs rhs
let sri = filter (`notElem` lidents') sr0
sr = CIStaticRefs sri
et <- genEntryType args
ll <- loadLiveFun lids
- (static, regs, upd) <-
+ (appK, regs, upd) <-
if et == CIThunk
then do
r <- updateThunk
- pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r)
- else return (StaticFun eidt (map StaticObjArg lidents'),
- (if null lidents then CIRegs 1 (concatMap idJSRep args)
- else CIRegs 0 (PtrV : concatMap idJSRep args))
- , mempty)
+ pure (SAKThunk, CIRegs 0 [PtrV], r)
+ else
+ let regs = if null lidents then CIRegs 1 (concatMap idJSRep args)
+ else CIRegs 0 (PtrV : concatMap idJSRep args)
+ in pure (SAKFun, regs, mempty)
setcc <- ifProfiling $
if et == CIThunk
then enterCostCentreThunk
@@ -359,5 +360,5 @@ genToplevelRhs i rhs = case rhs of
, ciStatic = sr
}
ccId <- costCentreStackLbl cc
- emitStatic idt static ccId
+ emitStatic idt (StaticScalar $ StaticApp appK eidt $ map StaticObjArg lidents') ccId
return $ (FuncStat eid [] (ll <> upd <> setcc <> body))
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -606,6 +606,32 @@ genCase ctx bnd e at alts l
, ExprInline
)
+ | StgLit (LitString bs) <- e
+ , [GenStgAlt DEFAULT _ rhs] <- alts
+ , StgApp i args <- rhs
+ , idName i == unpackCStringName
+ , [StgVarArg b'] <- args
+ , bnd == b'
+ , Just d <- decodeModifiedUTF8 bs
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = return
+ ( top |= app "h$toHsStringA" [toJExpr d]
+ , ExprInline
+ )
+
+ | StgLit (LitString bs) <- e
+ , [GenStgAlt DEFAULT _ rhs] <- alts
+ , StgApp i args <- rhs
+ , idName i == unpackCStringUtf8Name
+ , [StgVarArg b'] <- args
+ , bnd == b'
+ , Just d <- decodeModifiedUTF8 bs
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = return
+ ( top |= app "h$toHsString" [toJExpr d]
+ , ExprInline
+ )
+
| isInlineExpr e = do
bndi <- identsForId bnd
let ctx' = ctxSetTop bnd
=====================================
compiler/GHC/StgToJS/Ids.hs
=====================================
@@ -155,7 +155,7 @@ cachedIdentForId i mi id_type = do
-- Now update the GlobalId cache, if required
- let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain
+ let update_global_cache = isGlobalId i && id_type == IdPlain
-- fixme also allow caching entries for lifting?
when (update_global_cache) $ do
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -24,8 +24,6 @@ module GHC.StgToJS.Linker.Linker
( jsLinkBinary
, jsLink
, embedJsFile
- , staticInitStat
- , staticDeclStat
, mkExportedFuns
, mkExportedModFuns
, computeLinkDependencies
@@ -1253,27 +1251,22 @@ staticInitStat :: StaticInfo -> JS.JStat
staticInitStat (StaticInfo i sv mcc) =
jStgStatToJS $
case sv of
- StaticData con args -> appS hdStiStr $ add_cc_arg
- [ global i
- , global con
- , jsStaticArgs args
- ]
- StaticFun f args -> appS hdStiStr $ add_cc_arg
- [ global i
- , global f
- , jsStaticArgs args
- ]
- StaticList args mt -> appS hdStlStr $ add_cc_arg
- [ global i
- , jsStaticArgs args
- , toJExpr $ maybe null_ (toJExpr . TxtI) mt
- ]
- StaticThunk (Just (f,args)) -> appS hdStcStr $ add_cc_arg
- [ global i
- , global f
- , jsStaticArgs args
- ]
- _ -> mempty
+ StaticScalar (StaticApp k app args) -> appS
+ (if k == SAKThunk then hdStcStr else hdStiStr)
+ $ add_cc_arg
+ [ global i
+ , global app
+ , jsStaticArgs args
+ ]
+
+ StaticList args mt -> appS hdStlStr
+ $ add_cc_arg
+ [ global i
+ , jsStaticArgs args
+ , toJExpr $ maybe null_ (toJExpr . TxtI) mt
+ ]
+
+ StaticUnboxed _ -> mempty
where
-- add optional cost-center argument
add_cc_arg as = case mcc of
@@ -1286,20 +1279,15 @@ staticDeclStat (StaticInfo global_name static_value _) = jStgStatToJS decl
where
global_ident = name global_name
decl_init v = global_ident ||= v
- decl_no_init = appS hdDiStr [toJExpr global_ident]
decl = case static_value of
StaticUnboxed u -> decl_init (unboxed_expr u)
- StaticThunk Nothing -> decl_no_init -- CAF initialized in an alternative way
_ -> decl_init (app hdDStr [])
unboxed_expr = \case
StaticUnboxedBool b -> app hdPStr [toJExpr b]
StaticUnboxedInt i -> app hdPStr [toJExpr i]
StaticUnboxedDouble d -> app hdPStr [toJExpr (unSaneDouble d)]
- -- GHCJS used a function wrapper for this:
- -- StaticUnboxedString str -> ApplExpr (initStr str) []
- -- But we are defining it statically for now.
StaticUnboxedString str -> initStr str
StaticUnboxedStringOffset {} -> 0
=====================================
compiler/GHC/StgToJS/Monad.hs
=====================================
@@ -153,26 +153,23 @@ getGlobalIdCache = State.gets (ggsGlobalIdCache . gsGroup)
setGlobalIdCache :: GlobalIdCache -> G ()
setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}})
-
data GlobalOcc = GlobalOcc
- { global_ident :: !Ident
- , global_id :: !Id
+ { global_id :: !Id
, global_count :: !Word
}
instance Outputable GlobalOcc where
ppr g = hang (text "GlobalOcc") 2 $ vcat
- [ hcat [text "Ident: ", ppr (global_ident g)]
- , hcat [text "Id:", ppr (global_id g)]
+ [ hcat [text "Id:", ppr (global_id g)]
, hcat [text "Count:", ppr (global_count g)]
]
--- | Return number of occurrences of every global id used in the given JStgStat.
+-- | Return occurrences of every global id used in the given JStgStat.
-- Sort by increasing occurrence count.
-globalOccs :: JStgStat -> G [GlobalOcc]
+globalOccs :: JStgStat -> G [Id]
globalOccs jst = do
GlobalIdCache gidc <- getGlobalIdCache
- -- build a map form Ident Unique to (Ident, Id, Count)
+ -- build a map form Ident Unique to (Id, Count)
let
cmp_cnt g1 g2 = compare (global_count g1) (global_count g2)
inc g1 g2 = g1 { global_count = global_count g1 + global_count g2 }
@@ -186,7 +183,7 @@ globalOccs jst = do
Just (_k,gid) ->
-- add it to the list of already found global ids. Increasing
-- count by 1
- let g = GlobalOcc i gid 1
+ let g = GlobalOcc gid 1
in go (addToUFM_C inc gids i g) is
- pure $ go emptyUFM (identsS jst)
+ pure $ map global_id $ go emptyUFM $ identsS jst
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -615,16 +615,16 @@ instance Binary StaticInfo where
get bh = StaticInfo <$> get bh <*> get bh <*> get bh
instance Binary StaticVal where
- put_ bh (StaticFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args
- put_ bh (StaticThunk t) = putByte bh 2 >> put_ bh t
- put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u
- put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args
- put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t
+ put_ bh (StaticScalar (StaticApp SAKFun f args)) = putByte bh 1 >> put_ bh f >> put_ bh args
+ put_ bh (StaticScalar (StaticApp SAKThunk f args)) = putByte bh 2 >> put_ bh f >> put_ bh args
+ put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u
+ put_ bh (StaticScalar (StaticApp SAKData dc args)) = putByte bh 4 >> put_ bh dc >> put_ bh args
+ put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t
get bh = getByte bh >>= \case
- 1 -> StaticFun <$> get bh <*> get bh
- 2 -> StaticThunk <$> get bh
+ 1 -> StaticScalar <$> (StaticApp SAKFun <$> get bh <*> get bh)
+ 2 -> StaticScalar <$> (StaticApp SAKThunk <$> get bh <*> get bh)
3 -> StaticUnboxed <$> get bh
- 4 -> StaticData <$> get bh <*> get bh
+ 4 -> StaticScalar <$> (StaticApp SAKData <$> get bh <*> get bh)
5 -> StaticList <$> get bh <*> get bh
n -> error ("Binary get bh StaticVal: invalid tag " ++ show n)
=====================================
compiler/GHC/StgToJS/Symbols.hs
=====================================
@@ -849,9 +849,6 @@ unknown = fsLit "<unknown>"
typeof :: FastString
typeof = fsLit "typeof"
-hdRawStr :: FastString
-hdRawStr = fsLit "h$rstr"
-
throwStr :: FastString
throwStr = fsLit "throw"
@@ -1213,8 +1210,6 @@ hdStlStr = fsLit "h$stl"
hdStiStr :: FastString
hdStiStr = fsLit "h$sti"
-hdStrStr :: FastString
-hdStrStr = fsLit "h$str"
------------------------------ Pack/Unpack --------------------------------------------
hdDecodeUtf8Z :: FastString
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -231,18 +231,25 @@ data StaticInfo = StaticInfo
, siCC :: !(Maybe Ident) -- ^ optional CCS name
} deriving stock (Eq, Show)
+data StaticAppKind
+ = SAKFun
+ -- ^ heap object for function
+ | SAKThunk
+ -- ^ heap object for CAF
+ | SAKData
+ -- ^ regular datacon app
+ deriving stock (Eq, Show)
+
+-- Static scalar application
+data StaticApp = StaticApp StaticAppKind !FastString [StaticArg]
+ deriving stock (Eq, Show)
+
data StaticVal
- = StaticFun !FastString [StaticArg]
- -- ^ heap object for function
- | StaticThunk !(Maybe (FastString,[StaticArg]))
- -- ^ heap object for CAF (field is Nothing when thunk is initialized in an
- -- alternative way, like string thunks through h$str)
- | StaticUnboxed !StaticUnboxed
+ = StaticUnboxed !StaticUnboxed
-- ^ unboxed constructor (Bool, Int, Double etc)
- | StaticData !FastString [StaticArg]
- -- ^ regular datacon app
| StaticList [StaticArg] (Maybe FastString)
-- ^ list initializer (with optional tail)
+ | StaticScalar StaticApp
deriving stock (Eq, Show)
data StaticUnboxed
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -403,9 +403,7 @@ pprImpliedExtensions extension = case implied of
xs -> parens $ "implied by" <+> unquotedListWith "and" xs
where implied = map (quotes . ppr)
. filter (\ext -> extensionDeprecation ext == ExtensionNotDeprecated)
- . map (\(impl, _, _) -> impl)
- . filter (\(_, t, orig) -> orig == extension && t == turnOn)
- $ impliedXFlags
+ $ [impl | (impl, On orig) <- impliedXFlags, orig == extension]
pprPrefixUnqual :: Name -> SDoc
pprPrefixUnqual name =
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -99,7 +99,8 @@ multiSetup pkg_s = do
writeFile' (resp_file root p) (intercalate "\n" (normalise_ghc arg_list
++ modules cd
++ concatMap rexp (reexportModules cd)
- ++ ["-outputdir", hidir]))
+ ++ ["-outputdir", hidir,
+ "-this-package-name", pkgName p]))
return (resp_file root p)
=====================================
rts/js/string.js
=====================================
@@ -1,53 +1,5 @@
//#OPTIONS: CPP
-// encode a string constant
-function h$str(s) {
- var enc = null;
- return function() {
- if(enc === null) {
- enc = h$encodeModifiedUtf8(s);
- }
- return enc;
- }
-}
-
-// encode a packed string
-// since \0 is used to separate strings (and a common occurrence)
-// we add the following mapping:
-// - \0 -> \cz\0
-// - \cz -> \cz\cz
-//
-// decoding to bytes, the following is produced:
-// - \cz\0 -> C0 80
-// - \cz\cz -> 1A
-//
-// additionally, for dealing with raw binary data we have an escape sequence
-// to pack base64 encoded runs:
-//
-// - \cz\xNN -> followed by NN-0x1f (31 decimal) bytes of base64 encoded
-// data. supported range: 0x20 .. 0x9f (1-128 bytes data)
-//
-
-function h$pstr(s) {
- var enc = null;
- return function() {
- if(enc === null) {
- enc = h$encodePackedUtf8(s);
- }
- return enc;
- }
-}
-// encode a raw string from bytes
-function h$rstr(d) {
- var enc = null;
- return function() {
- if(enc === null) {
- enc = h$rawStringData(d);
- }
- return enc;
- }
-}
-
// these aren't added to the CAFs, so the list stays in mem indefinitely, is that a problem?
#ifdef GHCJS_PROF
function h$strt(str, cc) { return MK_LAZY_CC(function() { return h$toHsString(str, cc); }, cc); }
@@ -265,10 +217,27 @@ function h$encodeUtf8(str) {
return h$encodeUtf8Internal(str, false, false);
}
+// encode a string constant
function h$encodeModifiedUtf8(str) {
return h$encodeUtf8Internal(str, true, false);
}
+// encode a packed string
+// since \0 is used to separate strings (and a common occurrence)
+// we add the following mapping:
+// - \0 -> \cz\0
+// - \cz -> \cz\cz
+//
+// decoding to bytes, the following is produced:
+// - \cz\0 -> C0 80
+// - \cz\cz -> 1A
+//
+// additionally, for dealing with raw binary data we have an escape sequence
+// to pack base64 encoded runs:
+//
+// - \cz\xNN -> followed by NN-0x1f (31 decimal) bytes of base64 encoded
+// data. supported range: 0x20 .. 0x9f (1-128 bytes data)
+//
function h$encodePackedUtf8(str) {
return h$encodeUtf8Internal(str, false, true);
}
@@ -759,6 +728,30 @@ function h$appendToHsStringA(str, appendTo) {
return r;
}
+// unpack utf8 string, append to existing Haskell string
+#ifdef GHCJS_PROF
+function h$appendToHsString(str, appendTo, cc) {
+#else
+function h$appendToHsString(str, appendTo) {
+#endif
+ var i = str.length - 1;
+ // we need to make an updatable thunk here
+ // if we embed the given closure in a CONS cell.
+ // (#24495)
+ var r = i == 0 ? appendTo : MK_UPD_THUNK(appendTo);
+ while(i>=0) {
+ // Copied from h$toHsString
+ var cp = str.charCodeAt(i);
+ if(cp >= 0xDC00 && cp <= 0xDFFF && i > 0) {
+ --i;
+ cp = (cp - 0xDC00) + (str.charCodeAt(i) - 0xD800) * 1024 + 0x10000;
+ }
+ r = MK_CONS_CC(cp, r, cc);
+ --i;
+ }
+ return r;
+}
+
// throw e wrapped in a GHCJS.Prim.JSException in the current thread
function h$throwJSException(e) {
// create a JSException object and wrap it in a SomeException
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/02c3c58b5491dac950ea14f0243fd869d1671086...b3691a29fc2e80df4af3c2f75fdc7fd45afb47c1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/02c3c58b5491dac950ea14f0243fd869d1671086...b3691a29fc2e80df4af3c2f75fdc7fd45afb47c1
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241125/286a7180/attachment-0001.html>
More information about the ghc-commits
mailing list