Skip to content

Commit b55126d

Browse files
csabahruskacsabahruska
committed
update wpc-plugin for GHC 9.10.1 ; store wired in unit ids in .ghc_stgapp ; store IR files uncomprossed in a separate folder
1 parent 03ba959 commit b55126d

File tree

5 files changed

+70
-19
lines changed

5 files changed

+70
-19
lines changed

‎wpc-plugin/src/WPC/GhcStgApp.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -122,6 +122,7 @@ writeGhcStgApp dflags unit_env hpt = do
122122
, ("extra-frameworks", JSArray $ map JSString $ cmdlineFrameworks dflags)
123123
, ("ld-options", arrOfStr appLdOptions)
124124
, ("unit-db-paths", arrOfAbsPath $ maybe [] (map unitDatabasePath) $ ue_unit_dbs unit_env)
125+
, ("wired-in-unit-ids", JSArray $ map (JSString . pp) wiredInUnitIds)
125126
, ("app-deps", app_deps)
126127
]
127128

‎wpc-plugin/src/WPC/Modpak.hs‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,10 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls
6464
modpak_output = odir </> "extra-compilation-artifacts" </> "wpc-plugin" </> "modpaks" </> makeRelative odir modpak_output0
6565
createDirectoryIfMissing True (takeDirectory modpak_output)
6666

67+
let moddir_output0 = replaceExtension (ml_hi_file location) (objectSuf dflags)
68+
let moddir_output = odir </> "extra-compilation-artifacts" </> "wpc-plugin" </> "hs-modules" </> makeRelative odir moddir_output0
69+
createDirectoryIfMissing True moddir_output
70+
6771
-- stgbin
6872
stgbinFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule (objectSuf dflags ++ "_stgbin")
6973
BSL.writeFile stgbinFile stgBin
@@ -114,6 +118,7 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls
114118
, FileOption "--entryPath=" dst
115119
, FileOption "--sourcePath=" src
116120
]
121+
117122
runSomething logger "finish .modpak" "zip-cmd" $
118123
[ Option "CreateArchive", FileOption "--zipPath=" modpak_output] ++
119124
addToZip "module.stgbin" stgbinFile ++
@@ -136,6 +141,36 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls
136141
Just fn -> addToZip "module_stub.c" fn
137142
)
138143

144+
-- mod dir output
145+
let moveToDir dst src = renameFile src (moddir_output </> dst)
146+
copyToDir dst src = copyFile src (moddir_output </> dst)
147+
moveToDir "module.stgbin" stgbinFile
148+
moveToDir "module.fullcore-hi" fullcoreHiFile
149+
moveToDir "module.ghcstg" ghcstgFile
150+
moveToDir "module.ghccore" ghccoreFile
151+
moveToDir "module.cmm" cmm_filename
152+
copyToDir "module.s" output_filename
153+
moveToDir "module.info" infoFile
154+
case mSrcPath of
155+
Nothing -> pure ()
156+
Just fn -> copyToDir "module.hs" fn
157+
if has_stub_h
158+
then copyToDir "module_stub.h" (mkStubPaths (initFinderOpts dflags) modName location)
159+
else pure ()
160+
case m_stub_c of
161+
Nothing -> pure ()
162+
Just fn -> copyToDir "module_stub.c" fn
163+
{-
164+
-- compress
165+
runSomething logger "compress module IRs" "zstd" $
166+
[ Option "-q"
167+
, Option "-T0"
168+
, Option "--rm"
169+
, Option "-r"
170+
, FileOption "" moddir_output
171+
]
172+
-}
173+
139174
writeFullCoreInterface :: HscEnv -> ModGuts -> ModSummary -> FilePath -> IO ()
140175
writeFullCoreInterface hscEnv0 mod_guts mod_summary output_name = do
141176
let logger = hsc_logger hscEnv0

‎wpc-plugin/src/WPC/Plugin.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -54,14 +54,14 @@ coreToDosFun :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
5454
coreToDosFun cmdOpts todo0 = do
5555
let captureCore :: ModGuts -> CoreM ModGuts
5656
captureCore mg = do
57-
putMsgS $ "wpc-plugin captureCore pass"
57+
--putMsgS $ "wpc-plugin captureCore pass"
5858
liftIO $ modifyIORef globalEnvIORef $ \d -> d {geModGuts = Just mg}
5959
pure mg
6060

6161
todo = todo0 ++ [CoreDoPluginPass "capture IR" captureCore]
6262

63-
putMsgS $ "wpc-plugin coreToDosFun cmdOpts: " ++ show cmdOpts
64-
putMsg $ text "wpc-plugin coreToDosFun todo: " <+> vcat (map ppr todo)
63+
--putMsgS $ "wpc-plugin coreToDosFun cmdOpts: " ++ show cmdOpts
64+
--putMsg $ text "wpc-plugin coreToDosFun todo: " <+> vcat (map ppr todo)
6565
return todo
6666

6767
driverFun :: [CommandLineOption] -> HscEnv -> IO HscEnv
@@ -246,7 +246,7 @@ linkFun ghcLink dflags isBatchMode hpt = do
246246
GlobalEnv{..} <- readIORef globalEnvIORef
247247
let Just HscEnv{..} = geHscEnv
248248
hooks = hsc_hooks {linkHook = Nothing}
249-
result <- Pipeline.link ghcLink hsc_logger hsc_tmpfs hooks dflags hsc_unit_env isBatchMode Nothing hpt
249+
result <- Pipeline.link ghcLink hsc_logger hsc_tmpfs hsc_FC hooks dflags hsc_unit_env isBatchMode Nothing hpt
250250
{-
251251
IDEA: generate ghcstgapp file along with modpak file for the main module
252252
do not use the link hook

‎wpc-plugin/src/WPC/StgToExtStg.hs‎

Lines changed: 28 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -118,10 +118,10 @@ bs8SDoc :: (?ienv :: ImplicitEnv) => GHC.SDoc -> BS8.ByteString
118118
bs8SDoc = BS8.pack . GHC.showSDoc (ieDflags ?ienv)
119119

120120
uniqueKey :: GHC.Uniquable a => a -> Int
121-
uniqueKey = GHC.getKey . GHC.getUnique
121+
uniqueKey = fromIntegral . GHC.getKey . GHC.getUnique
122122

123123
cvtUnique :: GHC.Unique -> Unique
124-
cvtUnique u = Unique a b
124+
cvtUnique u = Unique a (fromIntegral b)
125125
where (a,b) = GHC.unpkUnique u
126126

127127
-- name conversion
@@ -172,13 +172,15 @@ cvtUnhelpfulSpanReason = \case
172172
GHC.UnhelpfulOther s -> UnhelpfulOther $ GHC.bytesFS s
173173

174174
-- tickish conversion
175+
cvtLexicalFastString :: GHC.LexicalFastString -> BS8.ByteString
176+
cvtLexicalFastString (GHC.LexicalFastString fs) = GHC.bytesFS fs
175177

176178
cvtTickish :: GHC.StgTickish -> Tickish
177179
cvtTickish = \case
178180
GHC.ProfNote{} -> ProfNote
179181
GHC.HpcTick{} -> HpcTick
180182
GHC.Breakpoint{} -> Breakpoint
181-
GHC.SourceNote{..} -> SourceNote (cvtRealSrcSpan sourceSpan) (BS8.pack sourceName)
183+
GHC.SourceNote{..} -> SourceNote (cvtRealSrcSpan sourceSpan) (cvtLexicalFastString sourceName)
182184

183185
-- data con conversion
184186

@@ -303,17 +305,22 @@ cvtTypeNormal t
303305
| GHC.isUnboxedSumType t || GHC.isUnboxedTupleType t
304306
= UnboxedTuple (map cvtPrimRep $ GHC.typePrimRep t)
305307

306-
| [rep] <- GHC.typePrimRepArgs t
308+
| [rep] <- GHC.typePrimRep t
307309
= SingleValue (cvtPrimRep rep)
308310

309311
| otherwise
310312
= error $ "could not convert type: " ++ ppr t
311313

314+
cvtPrimRepOrVoidRep :: GHC.PrimOrVoidRep -> PrimRep
315+
cvtPrimRepOrVoidRep = \case
316+
GHC.VoidRep -> VoidRep
317+
GHC.NVRep r -> cvtPrimRep r
318+
312319
cvtPrimRep :: GHC.PrimRep -> PrimRep
313320
cvtPrimRep = \case
314-
GHC.VoidRep -> VoidRep
315-
GHC.LiftedRep -> LiftedRep
316-
GHC.UnliftedRep -> UnliftedRep
321+
GHC.BoxedRep levity -> case levity of
322+
Just GHC.Unlifted -> UnliftedRep
323+
_ -> LiftedRep
317324
GHC.Int8Rep -> Int8Rep
318325
GHC.Int16Rep -> Int16Rep
319326
GHC.Int32Rep -> Int32Rep
@@ -401,6 +408,7 @@ cvtIdDetails i = case GHC.idDetails i of
401408
GHC.DataConWorkId d -> DataConWorkId <$> cvtDataCon d
402409
GHC.DataConWrapId d -> DataConWrapId <$> cvtDataCon d
403410
GHC.ClassOpId{} -> pure ClassOpId
411+
GHC.RepPolyId{} -> pure RepPolyId
404412
GHC.PrimOpId{} -> pure PrimOpId
405413
GHC.FCallId{} -> pure FCallId
406414
GHC.TickBoxOpId{} -> pure TickBoxOpId
@@ -419,7 +427,7 @@ cvtBinderIdClosureParam details msg v
419427
| GHC.isId v = SBinder
420428
{ sbinderName = cvtOccName $ GHC.getOccName v
421429
, sbinderId = BinderId . cvtUnique . GHC.idUnique $ v
422-
, sbinderType = SingleValue . cvtPrimRep . {-trpp (unwords [msg, "cvtBinderIdClosureParam", ppr v])-} GHC.typePrimRep1 $ GHC.idType v
430+
, sbinderType = SingleValue . cvtPrimRepOrVoidRep . {-trpp (unwords [msg, "cvtBinderIdClosureParam", ppr v])-} GHC.typePrimRep1 $ GHC.idType v
423431
, sbinderTypeSig = BS8.pack . ppr $ GHC.idType v
424432
, sbinderScope = cvtScope v
425433
, sbinderDetails = details
@@ -460,7 +468,7 @@ cvtBinderIdM msg i = do
460468

461469
cvtSourceText :: GHC.SourceText -> SourceText
462470
cvtSourceText = \case
463-
GHC.SourceText s -> SourceText (BS8.pack s)
471+
GHC.SourceText s -> SourceText (GHC.bytesFS s)
464472
GHC.NoSourceText -> NoSourceText
465473

466474
cvtCCallTarget :: GHC.CCallTarget -> CCallTarget
@@ -529,11 +537,18 @@ cvtConAppTypeArgs tys = pure . unsafePerformIO $ catch (evaluate $ map (cvtType
529537
-> pure []
530538
e -> throw e
531539

540+
cvtConAppTypeArgs2 :: (?ienv :: ImplicitEnv) => [[GHC.PrimRep]] -> M [Type]
541+
cvtConAppTypeArgs2 tys = pure . unsafePerformIO $ catch (evaluate [UnboxedTuple $ map cvtPrimRep l | l <- tys]) $ \case
542+
GHC.Panic msg
543+
| "mkSeqs shouldn't use the type arg" `isInfixOf` msg
544+
-> pure []
545+
e -> throw e
546+
532547
cvtExpr :: (?ienv :: ImplicitEnv) => GHC.CgStgExpr -> M SExpr
533548
cvtExpr = \case
534549
GHC.StgApp f ps -> StgApp <$> cvtOccId f <*> mapM cvtArg ps
535550
GHC.StgLit l -> pure $ StgLit (cvtLit l)
536-
GHC.StgConApp dc _ ps ts -> StgConApp <$> cvtDataCon dc <*> mapM cvtArg ps <*> cvtConAppTypeArgs ts
551+
GHC.StgConApp dc _ ps ts -> StgConApp <$> cvtDataCon dc <*> mapM cvtArg ps <*> cvtConAppTypeArgs2 ts
537552
GHC.StgOpApp o ps t -> StgOpApp (cvtOp o) <$> mapM cvtArg ps <*> pure (cvtType "StgOpApp" t) <*> cvtDataTyConIdFromType t
538553
GHC.StgCase e b at al -> StgCase <$> cvtExpr e <*> cvtBinderIdM "StgCase" b <*> cvtAltType at <*> mapM cvtAlt al
539554
GHC.StgLet _ b e -> StgLet <$> cvtBind b <*> cvtExpr e
@@ -551,8 +566,8 @@ cvtUpdateFlag = \case
551566

552567
cvtRhs :: (?ienv :: ImplicitEnv) => GHC.CgStgRhs -> M SRhs
553568
cvtRhs = \case
554-
GHC.StgRhsClosure _ _ u bs e -> StgRhsClosure [] (cvtUpdateFlag u) <$> mapM (cvtBinderIdClosureParamM "StgRhsClosure") bs <*> cvtExpr e
555-
GHC.StgRhsCon _ dc _ _ args -> StgRhsCon <$> cvtDataCon dc <*> mapM cvtArg args
569+
GHC.StgRhsClosure _ _ u bs e _ -> StgRhsClosure [] (cvtUpdateFlag u) <$> mapM (cvtBinderIdClosureParamM "StgRhsClosure") bs <*> cvtExpr e
570+
GHC.StgRhsCon _ dc _ _ args _ -> StgRhsCon <$> cvtDataCon dc <*> mapM cvtArg args
556571

557572
-- bind and top-bind conversion
558573

@@ -713,7 +728,7 @@ mkSDataCon dc = SDataCon
713728
--dcpp msg f a = trace ("mkSDataCon " ++ msg ++ " : " ++ ppr a) $ f a
714729
n = GHC.getName dc
715730
getConArgRep = \case
716-
GHC.VoidRep -> [] -- HINT: drop VoidRep arguments, the STG constructor builder code also ignores them
731+
--GHC.VoidRep -> [] -- HINT: drop VoidRep arguments, the STG constructor builder code also ignores them
717732
r -> [cvtPrimRep r]
718733

719734
topBindIds :: GHC.CgStgTopBinding -> [GHC.Id]

‎wpc-plugin/wpc-plugin.cabal‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,9 @@
11
cabal-version: 2.4
22
name: wpc-plugin
3-
version: 1.0.1
3+
version: 1.1.0
44

55
-- A short (one-line) description of the package.
6-
synopsis: WPC plugin for GHC 9.6
6+
synopsis: WPC plugin for GHC 9.10.1
77

88
-- A longer description of the package.
99
-- description:

0 commit comments

Comments
 (0)