update wpc-plugin for GHC 9.10.1 ; store wired in unit ids in .ghc_stgapp ; store IR files uncomprossed in a separate folder

Author: csabahruska

wpc-plugin/src/WPC/GhcStgApp.hs

@@ -122,6 +122,7 @@ writeGhcStgApp dflags unit_env hpt = do
     , ("extra-frameworks",  JSArray $ map JSString $ cmdlineFrameworks dflags)
     , ("ld-options",        arrOfStr appLdOptions)
     , ("unit-db-paths",     arrOfAbsPath $ maybe [] (map unitDatabasePath) $ ue_unit_dbs unit_env)
+    , ("wired-in-unit-ids", JSArray $ map (JSString . pp) wiredInUnitIds)
     , ("app-deps",          app_deps)
     ]
 

wpc-plugin/src/WPC/Modpak.hs

@@ -64,6 +64,10 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls
       modpak_output   = odir </> "extra-compilation-artifacts" </> "wpc-plugin" </> "modpaks" </> makeRelative odir modpak_output0
   createDirectoryIfMissing True (takeDirectory modpak_output)
 
+  let moddir_output0  = replaceExtension (ml_hi_file location) (objectSuf dflags)
+  let moddir_output   = odir </> "extra-compilation-artifacts" </> "wpc-plugin" </> "hs-modules" </> makeRelative odir moddir_output0
+  createDirectoryIfMissing True moddir_output
+
   -- stgbin
   stgbinFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule (objectSuf dflags ++ "_stgbin")
   BSL.writeFile stgbinFile stgBin
@@ -114,6 +118,7 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls
         , FileOption "--entryPath=" dst
         , FileOption "--sourcePath=" src
         ]
+
   runSomething logger "finish .modpak" "zip-cmd" $
     [ Option "CreateArchive", FileOption "--zipPath=" modpak_output] ++
     addToZip "module.stgbin" stgbinFile ++
@@ -136,6 +141,36 @@ outputModPak hsc_env this_mod core_binds stg_binds foreign_stubs0 foreign_decls
       Just fn -> addToZip "module_stub.c" fn
     )
 
+  -- mod dir output
+  let moveToDir dst src = renameFile src (moddir_output </> dst)
+      copyToDir dst src = copyFile src (moddir_output </> dst)
+  moveToDir "module.stgbin" stgbinFile
+  moveToDir "module.fullcore-hi" fullcoreHiFile
+  moveToDir "module.ghcstg" ghcstgFile
+  moveToDir "module.ghccore" ghccoreFile
+  moveToDir "module.cmm" cmm_filename
+  copyToDir "module.s" output_filename
+  moveToDir "module.info" infoFile
+  case mSrcPath of
+    Nothing -> pure ()
+    Just fn -> copyToDir "module.hs" fn
+  if has_stub_h
+    then copyToDir "module_stub.h" (mkStubPaths (initFinderOpts dflags) modName location)
+    else pure ()
+  case m_stub_c of
+    Nothing   -> pure ()
+    Just fn -> copyToDir "module_stub.c" fn
+  {-
+  -- compress
+  runSomething logger "compress module IRs" "zstd" $
+    [ Option "-q"
+    , Option "-T0"
+    , Option "--rm"
+    , Option "-r"
+    , FileOption "" moddir_output
+    ]
+  -}
+
 writeFullCoreInterface :: HscEnv -> ModGuts -> ModSummary -> FilePath -> IO ()
 writeFullCoreInterface hscEnv0 mod_guts mod_summary output_name = do
   let logger  = hsc_logger hscEnv0

wpc-plugin/src/WPC/Plugin.hs

@@ -54,14 +54,14 @@ coreToDosFun :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
 coreToDosFun cmdOpts todo0 = do
   let captureCore :: ModGuts -> CoreM ModGuts
       captureCore mg = do
-        putMsgS $ "wpc-plugin captureCore pass"
+        --putMsgS $ "wpc-plugin captureCore pass"
         liftIO $ modifyIORef globalEnvIORef $ \d -> d {geModGuts = Just mg}
         pure mg
 
       todo = todo0 ++ [CoreDoPluginPass "capture IR" captureCore]
 
-  putMsgS $ "wpc-plugin coreToDosFun cmdOpts: " ++ show cmdOpts
-  putMsg $ text "wpc-plugin coreToDosFun todo: " <+> vcat (map ppr todo)
+  --putMsgS $ "wpc-plugin coreToDosFun cmdOpts: " ++ show cmdOpts
+  --putMsg $ text "wpc-plugin coreToDosFun todo: " <+> vcat (map ppr todo)
   return todo
 
 driverFun :: [CommandLineOption] -> HscEnv -> IO HscEnv
@@ -246,7 +246,7 @@ linkFun ghcLink dflags isBatchMode hpt = do
   GlobalEnv{..} <- readIORef globalEnvIORef
   let Just HscEnv{..} = geHscEnv
       hooks = hsc_hooks {linkHook = Nothing}
-  result <- Pipeline.link ghcLink hsc_logger hsc_tmpfs hooks dflags hsc_unit_env isBatchMode Nothing hpt
+  result <- Pipeline.link ghcLink hsc_logger hsc_tmpfs hsc_FC hooks dflags hsc_unit_env isBatchMode Nothing hpt
   {-
     IDEA: generate ghcstgapp file along with modpak file for the main module
             do not use the link hook

wpc-plugin/src/WPC/StgToExtStg.hs

@@ -118,10 +118,10 @@ bs8SDoc :: (?ienv :: ImplicitEnv) => GHC.SDoc -> BS8.ByteString
 bs8SDoc = BS8.pack . GHC.showSDoc (ieDflags ?ienv)
 
 uniqueKey :: GHC.Uniquable a => a -> Int
-uniqueKey = GHC.getKey . GHC.getUnique
+uniqueKey = fromIntegral . GHC.getKey . GHC.getUnique
 
 cvtUnique :: GHC.Unique -> Unique
-cvtUnique u = Unique a b
+cvtUnique u = Unique a (fromIntegral b)
   where (a,b) = GHC.unpkUnique u
 
 -- name conversion
@@ -172,13 +172,15 @@ cvtUnhelpfulSpanReason = \case
   GHC.UnhelpfulOther s        -> UnhelpfulOther $ GHC.bytesFS s
 
 -- tickish conversion
+cvtLexicalFastString :: GHC.LexicalFastString -> BS8.ByteString
+cvtLexicalFastString (GHC.LexicalFastString fs) = GHC.bytesFS fs
 
 cvtTickish :: GHC.StgTickish -> Tickish
 cvtTickish = \case
   GHC.ProfNote{}      -> ProfNote
   GHC.HpcTick{}       -> HpcTick
   GHC.Breakpoint{}    -> Breakpoint
-  GHC.SourceNote{..}  -> SourceNote (cvtRealSrcSpan sourceSpan) (BS8.pack sourceName)
+  GHC.SourceNote{..}  -> SourceNote (cvtRealSrcSpan sourceSpan) (cvtLexicalFastString sourceName)
 
 -- data con conversion
 
@@ -303,17 +305,22 @@ cvtTypeNormal t
   | GHC.isUnboxedSumType t || GHC.isUnboxedTupleType t
   = UnboxedTuple (map cvtPrimRep $ GHC.typePrimRep t)
 
-  | [rep] <- GHC.typePrimRepArgs t
+  | [rep] <- GHC.typePrimRep t
   = SingleValue (cvtPrimRep rep)
 
   | otherwise
   = error $ "could not convert type: " ++ ppr t
 
+cvtPrimRepOrVoidRep :: GHC.PrimOrVoidRep -> PrimRep
+cvtPrimRepOrVoidRep = \case
+    GHC.VoidRep -> VoidRep
+    GHC.NVRep r -> cvtPrimRep r
+
 cvtPrimRep :: GHC.PrimRep -> PrimRep
 cvtPrimRep = \case
-  GHC.VoidRep     -> VoidRep
-  GHC.LiftedRep   -> LiftedRep
-  GHC.UnliftedRep -> UnliftedRep
+  GHC.BoxedRep levity -> case levity of
+                            Just GHC.Unlifted -> UnliftedRep
+                            _                 -> LiftedRep
   GHC.Int8Rep     -> Int8Rep
   GHC.Int16Rep    -> Int16Rep
   GHC.Int32Rep    -> Int32Rep
@@ -401,6 +408,7 @@ cvtIdDetails i = case GHC.idDetails i of
   GHC.DataConWorkId d -> DataConWorkId <$> cvtDataCon d
   GHC.DataConWrapId d -> DataConWrapId <$> cvtDataCon d
   GHC.ClassOpId{}     -> pure ClassOpId
+  GHC.RepPolyId{}     -> pure RepPolyId
   GHC.PrimOpId{}      -> pure PrimOpId
   GHC.FCallId{}       -> pure FCallId
   GHC.TickBoxOpId{}   -> pure TickBoxOpId
@@ -419,7 +427,7 @@ cvtBinderIdClosureParam details msg v
   | GHC.isId v = SBinder
       { sbinderName     = cvtOccName $ GHC.getOccName v
       , sbinderId       = BinderId . cvtUnique . GHC.idUnique $ v
-      , sbinderType     = SingleValue . cvtPrimRep . {-trpp (unwords [msg, "cvtBinderIdClosureParam", ppr v])-} GHC.typePrimRep1 $ GHC.idType v
+      , sbinderType     = SingleValue . cvtPrimRepOrVoidRep . {-trpp (unwords [msg, "cvtBinderIdClosureParam", ppr v])-} GHC.typePrimRep1 $ GHC.idType v
       , sbinderTypeSig  = BS8.pack . ppr $ GHC.idType v
       , sbinderScope    = cvtScope v
       , sbinderDetails  = details
@@ -460,7 +468,7 @@ cvtBinderIdM msg i = do
 
 cvtSourceText :: GHC.SourceText -> SourceText
 cvtSourceText = \case
-  GHC.SourceText s  -> SourceText (BS8.pack s)
+  GHC.SourceText s  -> SourceText (GHC.bytesFS s)
   GHC.NoSourceText  -> NoSourceText
 
 cvtCCallTarget :: GHC.CCallTarget -> CCallTarget
@@ -529,11 +537,18 @@ cvtConAppTypeArgs tys = pure . unsafePerformIO $ catch (evaluate $ map (cvtType
     -> pure []
   e -> throw e
 
+cvtConAppTypeArgs2 :: (?ienv :: ImplicitEnv) => [[GHC.PrimRep]] -> M [Type]
+cvtConAppTypeArgs2 tys = pure . unsafePerformIO $ catch (evaluate [UnboxedTuple $ map cvtPrimRep l | l <- tys]) $ \case
+  GHC.Panic msg
+    | "mkSeqs shouldn't use the type arg" `isInfixOf` msg
+    -> pure []
+  e -> throw e
+
 cvtExpr :: (?ienv :: ImplicitEnv) => GHC.CgStgExpr -> M SExpr
 cvtExpr = \case
   GHC.StgApp f ps           -> StgApp <$> cvtOccId f <*> mapM cvtArg ps
   GHC.StgLit l              -> pure $ StgLit (cvtLit l)
-  GHC.StgConApp dc _ ps ts  -> StgConApp <$> cvtDataCon dc <*> mapM cvtArg ps <*> cvtConAppTypeArgs ts
+  GHC.StgConApp dc _ ps ts  -> StgConApp <$> cvtDataCon dc <*> mapM cvtArg ps <*> cvtConAppTypeArgs2 ts
   GHC.StgOpApp o ps t       -> StgOpApp (cvtOp o) <$> mapM cvtArg ps <*> pure (cvtType "StgOpApp" t) <*> cvtDataTyConIdFromType t
   GHC.StgCase e b at al     -> StgCase <$> cvtExpr e <*> cvtBinderIdM "StgCase" b <*> cvtAltType at <*> mapM cvtAlt al
   GHC.StgLet _ b e          -> StgLet <$> cvtBind b <*> cvtExpr e
@@ -551,8 +566,8 @@ cvtUpdateFlag = \case
 
 cvtRhs :: (?ienv :: ImplicitEnv) => GHC.CgStgRhs -> M SRhs
 cvtRhs = \case
-  GHC.StgRhsClosure _ _ u bs e  -> StgRhsClosure [] (cvtUpdateFlag u) <$> mapM (cvtBinderIdClosureParamM "StgRhsClosure") bs <*> cvtExpr e
-  GHC.StgRhsCon _ dc _ _ args   -> StgRhsCon <$> cvtDataCon dc <*> mapM cvtArg args
+  GHC.StgRhsClosure _ _ u bs e _ -> StgRhsClosure [] (cvtUpdateFlag u) <$> mapM (cvtBinderIdClosureParamM "StgRhsClosure") bs <*> cvtExpr e
+  GHC.StgRhsCon _ dc _ _ args _  -> StgRhsCon <$> cvtDataCon dc <*> mapM cvtArg args
 
 -- bind and top-bind conversion
 
@@ -713,7 +728,7 @@ mkSDataCon dc = SDataCon
       --dcpp msg f a = trace ("mkSDataCon " ++ msg ++ " : " ++ ppr a) $ f a
       n = GHC.getName dc
       getConArgRep = \case
-        GHC.VoidRep -> [] -- HINT: drop VoidRep arguments, the STG constructor builder code also ignores them
+        --GHC.VoidRep -> [] -- HINT: drop VoidRep arguments, the STG constructor builder code also ignores them
         r           -> [cvtPrimRep r]
 
 topBindIds :: GHC.CgStgTopBinding -> [GHC.Id]

wpc-plugin/wpc-plugin.cabal

@@ -1,9 +1,9 @@
 cabal-version:      2.4
 name:               wpc-plugin
-version:            1.0.1
+version:            1.1.0
 
 -- A short (one-line) description of the package.
-synopsis: WPC plugin for GHC 9.6
+synopsis: WPC plugin for GHC 9.10.1
 
 -- A longer description of the package.
 -- description: