genprimopcode: add --wrappers/--prim-module

Author: angerman

compiler/GHC/Builtin/PrimOps.hs

@@ -25,7 +25,9 @@ module GHC.Builtin.PrimOps (
 
         getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..),
 
-        PrimCall(..)
+        PrimCall(..),
+
+        primOpPrimModule, primOpWrappersModule
     ) where
 
 import GHC.Prelude
@@ -171,6 +173,12 @@ primOpDocs :: [(FastString, String)]
 primOpDeprecations :: [(OccName, FastString)]
 #include "primop-deprecations.hs-incl"
 
+primOpPrimModule :: String
+#include "primop-prim-module.hs-incl"
+
+primOpWrappersModule :: String
+#include "primop-wrappers-module.hs-incl"
+
 {-
 ************************************************************************
 *                                                                      *

compiler/Setup.hs

@@ -54,6 +54,8 @@ primopIncls =
     , ("primop-vector-tycons.hs-incl"     , "--primop-vector-tycons")
     , ("primop-docs.hs-incl"              , "--wired-in-docs")
     , ("primop-deprecations.hs-incl"      , "--wired-in-deprecations")
+, ("primop-prim-module.hs-incl"       , "--prim-module")
+    , ("primop-wrappers-module.hs-incl"   , "--wrappers-module")
     ]
 
 ghcAutogen :: Verbosity -> LocalBuildInfo -> IO ()

ghc/GHC/Driver/Session/Mode.hs

@@ -32,12 +32,16 @@ data PreStartupMode
   | ShowNumVersion                       -- ghc --numeric-version
   | ShowSupportedExtensions              -- ghc --supported-extensions
   | ShowOptions Bool {- isInteractive -} -- ghc --show-options
+  | PrintPrimModule                      -- ghc --print-prim-module
+  | PrintPrimWrappersModule              -- ghc --print-prim-wrappers-module
 
-showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
+showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode, printPrimModule, printPrimWrappersModule :: Mode
 showVersionMode             = mkPreStartupMode ShowVersion
 showNumVersionMode          = mkPreStartupMode ShowNumVersion
 showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
 showOptionsMode             = mkPreStartupMode (ShowOptions False)
+printPrimModule             = mkPreStartupMode PrintPrimModule
+printPrimWrappersModule     = mkPreStartupMode PrintPrimWrappersModule
 
 mkPreStartupMode :: PreStartupMode -> Mode
 mkPreStartupMode = Left
@@ -203,6 +207,8 @@ mode_flags =
   , defFlag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
   , defFlag "-info"                 (PassFlag (setMode showInfoMode))
   , defFlag "-show-options"         (PassFlag (setMode showOptionsMode))
+  , defFlag "-print-prim-module"    (PassFlag (setMode printPrimModule))
+  , defFlag "-print-prim-wrappers-module"  (PassFlag (setMode printPrimWrappersModule))
   , defFlag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
   , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
   , defFlag "-show-packages"        (PassFlag (setMode showUnitsMode))

ghc/Main.hs

@@ -37,6 +37,8 @@ import GHC.Driver.Config.Diagnostic
 import GHC.Platform
 import GHC.Platform.Host
 
+import GHC.Builtin.PrimOps (primOpPrimModule, primOpWrappersModule)
+
 #if defined(HAVE_INTERNAL_INTERPRETER)
 import GHCi.UI              ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
 #endif
@@ -138,6 +140,8 @@ main = do
                    ShowVersion               -> showVersion
                    ShowNumVersion            -> putStrLn cProjectVersion
                    ShowOptions isInteractive -> showOptions isInteractive
+                   PrintPrimModule           -> liftIO $ putStrLn primOpPrimModule
+                   PrintPrimWrappersModule   -> liftIO $ putStrLn primOpWrappersModule
         Right postStartupMode ->
             -- start our GHC session
             GHC.runGhc mbMinusB $ do

hadrian/src/Rules/Generate.hs

@@ -102,6 +102,8 @@ compilerDependencies = do
                   , "primop-vector-uniques.hs-incl"
                   , "primop-docs.hs-incl"
                   , "primop-deprecations.hs-incl"
+                  , "primop-prim-module.hs-incl"
+                  , "primop-wrappers-module.hs-incl"
                   , "GHC/Platform/Constants.hs"
                   , "GHC/Settings/Config.hs"
                   ]

hadrian/src/Settings/Builders/GenPrimopCode.hs

@@ -24,4 +24,6 @@ genPrimopCodeBuilderArgs = builder GenPrimopCode ? mconcat
     , output "//primop-vector-tycons.hs-incl"      ? arg "--primop-vector-tycons"
     , output "//primop-docs.hs-incl"               ? arg "--wired-in-docs"
     , output "//primop-deprecations.hs-incl"       ? arg "--wired-in-deprecations"
+    , output "//primop-prim-module.hs-incl"        ? arg "--prim-module"
+    , output "//primop-wrappers-module.hs-incl"    ? arg "--wrappers-module"
     , output "//primop-usage.hs-incl"              ? arg "--usage" ]

utils/genprimopcode/Main.hs

@@ -216,6 +216,12 @@ main = getArgs >>= \args ->
                       "--foundation-tests"
                          -> putStr (gen_foundation_tests p_o_specs)
 
+                      "--wrappers-module"
+                         -> putStr (gen_wrappers_module p_o_specs)
+
+                      "--prim-module"
+                         -> putStr (gen_hs_source_module p_o_specs)
+
                       _ -> error "Should not happen, known_args out of sync?"
                    )
 
@@ -242,13 +248,18 @@ known_args
        "--make-latex-doc",
        "--wired-in-docs",
        "--wired-in-deprecations",
-       "--foundation-tests"
+       "--foundation-tests",
+       "--wrappers-module",
+       "--prim-module"
      ]
 
 ------------------------------------------------------------------
 -- Code generators -----------------------------------------------
 ------------------------------------------------------------------
 
+gen_hs_source_module :: Info -> String
+gen_hs_source_module info = "primOpPrimModule = " ++ show (gen_hs_source info)
+
 gen_hs_source :: Info -> String
 gen_hs_source (Info defaults entries) =
        "{-\n"
@@ -475,6 +486,9 @@ In PrimopWrappers we set some crucial GHC options
   a very simple module and there is no optimisation to be done
 -}
 
+gen_wrappers_module :: Info -> String
+gen_wrappers_module info = "primOpWrappersModule = " ++ show (gen_wrappers info)
+
 gen_wrappers :: Info -> String
 gen_wrappers (Info _ entries)
    =    "-- | Users should not import this module.  It is GHC internal only.\n"

utils/genprimopcode/genprimopcode.cabal

@@ -31,5 +31,10 @@ Executable genprimopcode
                    AccessOps
     Build-Depends: base       >= 4   && < 5,
                    array
+
+    -- Happy generated unboxed sums without the necessary pragma.
+    default-extensions:
+      UnboxedSums
+
     if flag(build-tool-depends)
       build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0