never executed always true always false
    1 {-
    2 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
    3 
    4 \section{Code output phase}
    5 -}
    6 
    7 
    8 
    9 module GHC.Driver.CodeOutput
   10    ( codeOutput
   11    , outputForeignStubs
   12    , profilingInitCode
   13    , ipInitCode
   14    )
   15 where
   16 
   17 import GHC.Prelude
   18 import GHC.Platform
   19 import GHC.ForeignSrcLang
   20 
   21 import GHC.CmmToAsm     ( nativeCodeGen )
   22 import GHC.CmmToLlvm    ( llvmCodeGen )
   23 
   24 import GHC.CmmToC           ( cmmToC )
   25 import GHC.Cmm.Lint         ( cmmLint )
   26 import GHC.Cmm              ( RawCmmGroup )
   27 import GHC.Cmm.CLabel
   28 
   29 import GHC.Driver.Session
   30 import GHC.Driver.Config.Finder (initFinderOpts)
   31 import GHC.Driver.Config.CmmToAsm (initNCGConfig)
   32 import GHC.Driver.Ppr
   33 import GHC.Driver.Backend
   34 
   35 import qualified GHC.Data.ShortText as ST
   36 import GHC.Data.Stream           ( Stream )
   37 import qualified GHC.Data.Stream as Stream
   38 
   39 import GHC.Utils.TmpFs
   40 
   41 
   42 import GHC.Utils.Error
   43 import GHC.Utils.Outputable
   44 import GHC.Utils.Panic
   45 import GHC.Utils.Logger
   46 import GHC.Utils.Exception (bracket)
   47 import GHC.Utils.Ppr (Mode(..))
   48 
   49 import GHC.Unit
   50 import GHC.Unit.Finder      ( mkStubPaths )
   51 
   52 import GHC.Types.SrcLoc
   53 import GHC.Types.CostCentre
   54 import GHC.Types.ForeignStubs
   55 import GHC.Types.Unique.Supply ( mkSplitUniqSupply )
   56 
   57 import System.Directory
   58 import System.FilePath
   59 import System.IO
   60 import Data.Set (Set)
   61 import qualified Data.Set as Set
   62 
   63 {-
   64 ************************************************************************
   65 *                                                                      *
   66 \subsection{Steering}
   67 *                                                                      *
   68 ************************************************************************
   69 -}
   70 
   71 codeOutput
   72     :: Logger
   73     -> TmpFs
   74     -> DynFlags
   75     -> UnitState
   76     -> Module
   77     -> FilePath
   78     -> ModLocation
   79     -> (a -> ForeignStubs)
   80     -> [(ForeignSrcLang, FilePath)]
   81     -- ^ additional files to be compiled with the C compiler
   82     -> Set UnitId -- ^ Dependencies
   83     -> Stream IO RawCmmGroup a                       -- Compiled C--
   84     -> IO (FilePath,
   85            (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
   86            [(ForeignSrcLang, FilePath)]{-foreign_fps-},
   87            a)
   88 codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps
   89   cmm_stream
   90   =
   91     do  {
   92         -- Lint each CmmGroup as it goes past
   93         ; let linted_cmm_stream =
   94                  if gopt Opt_DoCmmLinting dflags
   95                     then Stream.mapM do_lint cmm_stream
   96                     else cmm_stream
   97 
   98               do_lint cmm = withTimingSilent logger
   99                   (text "CmmLint"<+>brackets (ppr this_mod))
  100                   (const ()) $ do
  101                 { case cmmLint (targetPlatform dflags) cmm of
  102                         Just err -> do { logMsg logger
  103                                                    MCDump
  104                                                    noSrcSpan
  105                                                    $ withPprStyle defaultDumpStyle err
  106                                        ; ghcExit logger 1
  107                                        }
  108                         Nothing  -> return ()
  109                 ; return cmm
  110                 }
  111 
  112         ; a <- case backend dflags of
  113                  NCG         -> outputAsm logger dflags this_mod location filenm
  114                                           linted_cmm_stream
  115                  ViaC        -> outputC logger dflags filenm linted_cmm_stream pkg_deps
  116                  LLVM        -> outputLlvm logger dflags filenm linted_cmm_stream
  117                  Interpreter -> panic "codeOutput: Interpreter"
  118                  NoBackend   -> panic "codeOutput: NoBackend"
  119         ; let stubs = genForeignStubs a
  120         ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
  121         ; return (filenm, stubs_exist, foreign_fps, a)
  122         }
  123 
  124 doOutput :: String -> (Handle -> IO a) -> IO a
  125 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
  126 
  127 {-
  128 ************************************************************************
  129 *                                                                      *
  130 \subsection{C}
  131 *                                                                      *
  132 ************************************************************************
  133 -}
  134 
  135 outputC :: Logger
  136         -> DynFlags
  137         -> FilePath
  138         -> Stream IO RawCmmGroup a
  139         -> Set UnitId
  140         -> IO a
  141 outputC logger dflags filenm cmm_stream unit_deps =
  142   withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
  143     let pkg_names = map unitIdString (Set.toAscList unit_deps)
  144     doOutput filenm $ \ h -> do
  145       hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
  146       hPutStr h "#include \"Stg.h\"\n"
  147       let platform = targetPlatform dflags
  148           writeC cmm = do
  149             let doc = cmmToC platform cmm
  150             putDumpFileMaybe logger Opt_D_dump_c_backend
  151                           "C backend output"
  152                           FormatC
  153                           doc
  154             let ctx = initSDocContext dflags (PprCode CStyle)
  155             printSDocLn ctx LeftMode h doc
  156       Stream.consume cmm_stream id writeC
  157 
  158 {-
  159 ************************************************************************
  160 *                                                                      *
  161 \subsection{Assembler}
  162 *                                                                      *
  163 ************************************************************************
  164 -}
  165 
  166 outputAsm :: Logger
  167           -> DynFlags
  168           -> Module
  169           -> ModLocation
  170           -> FilePath
  171           -> Stream IO RawCmmGroup a
  172           -> IO a
  173 outputAsm logger dflags this_mod location filenm cmm_stream = do
  174   ncg_uniqs <- mkSplitUniqSupply 'n'
  175   debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)
  176   let ncg_config = initNCGConfig dflags this_mod
  177   {-# SCC "OutputAsm" #-} doOutput filenm $
  178     \h -> {-# SCC "NativeCodeGen" #-}
  179       nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream
  180 
  181 {-
  182 ************************************************************************
  183 *                                                                      *
  184 \subsection{LLVM}
  185 *                                                                      *
  186 ************************************************************************
  187 -}
  188 
  189 outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
  190 outputLlvm logger dflags filenm cmm_stream =
  191   {-# SCC "llvm_output" #-} doOutput filenm $
  192     \f -> {-# SCC "llvm_CodeGen" #-}
  193       llvmCodeGen logger dflags f cmm_stream
  194 
  195 {-
  196 ************************************************************************
  197 *                                                                      *
  198 \subsection{Foreign import/export}
  199 *                                                                      *
  200 ************************************************************************
  201 -}
  202 
  203 outputForeignStubs
  204     :: Logger
  205     -> TmpFs
  206     -> DynFlags
  207     -> UnitState
  208     -> Module
  209     -> ModLocation
  210     -> ForeignStubs
  211     -> IO (Bool,         -- Header file created
  212            Maybe FilePath) -- C file created
  213 outputForeignStubs logger tmpfs dflags unit_state mod location stubs
  214  = do
  215    let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location
  216    stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
  217 
  218    case stubs of
  219      NoStubs ->
  220         return (False, Nothing)
  221 
  222      ForeignStubs (CHeader h_code) (CStub c_code) -> do
  223         let
  224             stub_c_output_d = pprCode CStyle c_code
  225             stub_c_output_w = showSDoc dflags stub_c_output_d
  226 
  227             -- Header file protos for "foreign export"ed functions.
  228             stub_h_output_d = pprCode CStyle h_code
  229             stub_h_output_w = showSDoc dflags stub_h_output_d
  230 
  231         createDirectoryIfMissing True (takeDirectory stub_h)
  232 
  233         putDumpFileMaybe logger Opt_D_dump_foreign
  234                       "Foreign export header file"
  235                       FormatC
  236                       stub_h_output_d
  237 
  238         -- we need the #includes from the rts package for the stub files
  239         let rts_includes =
  240                let mrts_pkg = lookupUnitId unit_state rtsUnitId
  241                    mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n"
  242                in case mrts_pkg of
  243                     Just rts_pkg -> concatMap mk_include (unitIncludes rts_pkg)
  244                     -- This case only happens when compiling foreign stub for the rts
  245                     -- library itself. The only time we do this at the moment is for
  246                     -- IPE information for the RTS info tables
  247                     Nothing -> ""
  248 
  249             -- wrapper code mentions the ffi_arg type, which comes from ffi.h
  250             ffi_includes
  251               | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"
  252               | otherwise = ""
  253 
  254         stub_h_file_exists
  255            <- outputForeignStubs_help stub_h stub_h_output_w
  256                 ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
  257 
  258         putDumpFileMaybe logger Opt_D_dump_foreign
  259                       "Foreign export stubs" FormatC stub_c_output_d
  260 
  261         stub_c_file_exists
  262            <- outputForeignStubs_help stub_c stub_c_output_w
  263                 ("#define IN_STG_CODE 0\n" ++
  264                  "#include <Rts.h>\n" ++
  265                  rts_includes ++
  266                  ffi_includes ++
  267                  cplusplus_hdr)
  268                  cplusplus_ftr
  269            -- We're adding the default hc_header to the stub file, but this
  270            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
  271            -- avoid the register variables etc. being enabled.
  272 
  273         return (stub_h_file_exists, if stub_c_file_exists
  274                                        then Just stub_c
  275                                        else Nothing )
  276  where
  277    cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"
  278    cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n"
  279 
  280 
  281 -- Don't use doOutput for dumping the f. export stubs
  282 -- since it is more than likely that the stubs file will
  283 -- turn out to be empty, in which case no file should be created.
  284 outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
  285 outputForeignStubs_help _fname ""      _header _footer = return False
  286 outputForeignStubs_help fname doc_str header footer
  287    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
  288         return True
  289 
  290 -- -----------------------------------------------------------------------------
  291 -- Initialising cost centres
  292 
  293 -- We must produce declarations for the cost-centres defined in this
  294 -- module;
  295 
  296 -- | Generate code to initialise cost centres
  297 profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub
  298 profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
  299  = CStub $ vcat
  300     $  map emit_cc_decl local_CCs
  301     ++ map emit_ccs_decl singleton_CCSs
  302     ++ [emit_cc_list local_CCs]
  303     ++ [emit_ccs_list singleton_CCSs]
  304     ++ [ text "static void prof_init_" <> ppr this_mod
  305             <> text "(void) __attribute__((constructor));"
  306        , text "static void prof_init_" <> ppr this_mod <> text "(void)"
  307        , braces (vcat
  308                  [ text "registerCcList" <> parens local_cc_list_label <> semi
  309                  , text "registerCcsList" <> parens singleton_cc_list_label <> semi
  310                  ])
  311        ]
  312  where
  313    emit_cc_decl cc =
  314        text "extern CostCentre" <+> cc_lbl <> text "[];"
  315      where cc_lbl = pdoc platform (mkCCLabel cc)
  316    local_cc_list_label = text "local_cc_" <> ppr this_mod
  317    emit_cc_list ccs =
  318       text "static CostCentre *" <> local_cc_list_label <> text "[] ="
  319       <+> braces (vcat $ [ pdoc platform (mkCCLabel cc) <> comma
  320                          | cc <- ccs
  321                          ] ++ [text "NULL"])
  322       <> semi
  323 
  324    emit_ccs_decl ccs =
  325        text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
  326      where ccs_lbl = pdoc platform (mkCCSLabel ccs)
  327    singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
  328    emit_ccs_list ccs =
  329       text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
  330       <+> braces (vcat $ [ pdoc platform (mkCCSLabel cc) <> comma
  331                          | cc <- ccs
  332                          ] ++ [text "NULL"])
  333       <> semi
  334 
  335 -- | Generate code to initialise info pointer origin
  336 -- See note [Mapping Info Tables to Source Positions]
  337 ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub
  338 ipInitCode dflags this_mod ents
  339  = if not (gopt Opt_InfoTableMap dflags)
  340     then mempty
  341     else CStub $ vcat
  342     $  map emit_ipe_decl ents
  343     ++ [emit_ipe_list ents]
  344     ++ [ text "static void ip_init_" <> ppr this_mod
  345             <> text "(void) __attribute__((constructor));"
  346        , text "static void ip_init_" <> ppr this_mod <> text "(void)"
  347        , braces (vcat
  348                  [ text "registerInfoProvList" <> parens local_ipe_list_label <> semi
  349                  ])
  350        ]
  351  where
  352    platform = targetPlatform dflags
  353    emit_ipe_decl ipe =
  354        text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
  355      where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)
  356    local_ipe_list_label = text "local_ipe_" <> ppr this_mod
  357    emit_ipe_list ipes =
  358       text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="
  359       <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma
  360                          | ipe <- ipes
  361                          ] ++ [text "NULL"])
  362       <> semi
  363 
  364