CodeOutput.lhs 8.84 KB
Newer Older
1 2 3 4 5 6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section{Code output phase}

\begin{code}
7
module CodeOutput( codeOutput, outputForeignStubs ) where
8 9 10

#include "HsVersions.h"

11
#ifndef OMIT_NATIVE_CODEGEN
12
import UniqSupply	( mkSplitUniqSupply )
13 14
import AsmCodeGen	( nativeCodeGen )
#endif
15

16 17 18
#ifdef ILX
import IlxGen		( ilxGen )
#endif
19

20
#ifdef JAVA
21
import JavaGen		( javaGen )
22
import OccurAnal	( occurAnalyseBinds )
23
import qualified PrintJava
24
import OccurAnal	( occurAnalyseBinds )
25
#endif
26

27 28
import PprC		( writeCs )
import CmmLint		( cmmLint )
29
import Packages
30
import DriverState	( getExplicitPackagesAnd, getPackageCIncludes )
31
import FastString	( unpackFS )
32
import Cmm		( Cmm )
33
import HscTypes
34
import CmdLineOpts
35
import ErrUtils		( dumpIfSet_dyn, showPass, ghcExit )
36
import Outputable
37
import Pretty		( Mode(..), printDoc )
38
import Module		( Module )
39
import ListSetOps	( removeDupsEq )
40
import Maybes		( firstJust )
41

42 43
import Directory	( doesFileExist )
import Data.List	( intersperse )
44
import Monad		( when )
45
import IO
46 47
\end{code}

48 49 50 51 52 53
%************************************************************************
%*									*
\subsection{Steering}
%*									*
%************************************************************************

54
\begin{code}
55
codeOutput :: DynFlags
56 57 58
	   -> Module
	   -> ForeignStubs
	   -> Dependencies
59
	   -> [Cmm]			-- Compiled C--
60
	   -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
61

62
codeOutput dflags this_mod foreign_stubs deps flat_abstractC
63
  = 
64
    -- You can have C (c_output) or assembly-language (ncg_output),
65 66 67
    -- but not both.  [Allowing for both gives a space leak on
    -- flat_abstractC.  WDP 94/10]

68
    -- Dunno if the above comment is still meaningful now.  JRS 001024.
69

70 71 72 73 74 75 76 77 78 79 80
    do	{ when (dopt Opt_DoCmmLinting dflags) $ do
		{ showPass dflags "CmmLint"
		; let lints = map cmmLint flat_abstractC
		; case firstJust lints of
			Just err -> do { printDump err
				       ; ghcExit 1
				       }
			Nothing  -> return ()
		}

	; showPass dflags "CodeOutput"
81
	; let filenm = dopt_OutName dflags 
82 83 84 85 86 87
	; stubs_exist <- outputForeignStubs dflags foreign_stubs
	; case dopt_HscLang dflags of {
             HscInterpreted -> return ();
             HscAsm         -> outputAsm dflags filenm flat_abstractC;
             HscC           -> outputC dflags filenm flat_abstractC stubs_exist
					deps foreign_stubs;
88 89
             HscJava        -> 
#ifdef JAVA
90
			       outputJava dflags filenm mod_name tycons core_binds;
91
#else
92
                               panic "Java support not compiled into this ghc";
93
#endif
94
	     HscILX         -> 
rrt's avatar
rrt committed
95
#ifdef ILX
96
			       let tycons = typeEnvTyCons type_env in
97
	                       outputIlx dflags filenm mod_name tycons stg_binds;
98
#else
99
                               panic "ILX support not compiled into this ghc";
rrt's avatar
rrt committed
100
#endif
101 102
	  }
	; return stubs_exist
103
	}
104

105
doOutput :: String -> (Handle -> IO ()) -> IO ()
106
doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
107 108 109 110 111 112 113 114 115 116
\end{code}


%************************************************************************
%*									*
\subsection{C}
%*									*
%************************************************************************

\begin{code}
117
outputC dflags filenm flat_absC 
118
	(stub_h_exists, _) dependencies foreign_stubs
119
  = do 
120 121 122 123 124 125 126 127 128 129 130 131 132
       -- figure out which header files to #include in the generated .hc file:
       --
       --   * extra_includes from packages
       --   * -#include options from the cmdline and OPTIONS pragmas
       --   * the _stub.h file, if there is one.
       --
       let packages = dep_pkgs dependencies
       pkg_configs <- getExplicitPackagesAnd packages
       let pkg_names = map name pkg_configs

       c_includes <- getPackageCIncludes pkg_configs
       let cmdline_includes = cmdlineHcIncludes dflags -- -#include options
       
133 134 135 136 137 138
	   ffi_decl_headers 
	      = case foreign_stubs of
		  NoStubs 		  -> []
		  ForeignStubs _ _ fdhs _ -> map unpackFS (fst (removeDupsEq fdhs))
			-- Remove duplicates, because distinct foreign import decls
			-- may cite the same #include.  Order doesn't matter.
139

140 141
           all_headers =  c_includes
		       ++ reverse cmdline_includes
142
		       ++ ffi_decl_headers
143 144 145 146 147 148 149 150

       let cc_injects = unlines (map mk_include all_headers)
       	   mk_include h_file = 
       	    case h_file of 
       	       '"':_{-"-} -> "#include "++h_file
       	       '<':_      -> "#include "++h_file
       	       _          -> "#include \""++h_file++"\""

151
       doOutput filenm $ \ h -> do
152 153
	  hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
	  hPutStr h cc_injects
154 155
	  when stub_h_exists $ 
	     hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
156
	  writeCs h flat_absC
157 158 159 160 161 162 163 164 165 166
\end{code}


%************************************************************************
%*									*
\subsection{Assembler}
%*									*
%************************************************************************

\begin{code}
167
outputAsm dflags filenm flat_absC
168

169
#ifndef OMIT_NATIVE_CODEGEN
170

171
  = do ncg_uniqs <- mkSplitUniqSupply 'n'
172 173
       ncg_output_d <- _scc_ "NativeCodeGen" 
			  nativeCodeGen dflags flat_absC ncg_uniqs
174 175 176
       dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
       _scc_ "OutputAsm" doOutput filenm $
	   \f -> printDoc LeftMode f ncg_output_d
177 178 179 180
  where

#else /* OMIT_NATIVE_CODEGEN */

181 182
  = pprPanic "This compiler was built without a native code generator"
	     (text "Use -fvia-C instead")
183 184 185

#endif
\end{code}
186 187


188 189 190 191 192
%************************************************************************
%*									*
\subsection{Java}
%*									*
%************************************************************************
193

194
\begin{code}
195
#ifdef JAVA
196
outputJava dflags filenm mod tycons core_binds
197
  = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
198
	-- User style printing for now to keep indentation
199
  where
200 201 202
    occ_anal_binds = occurAnalyseBinds core_binds
	-- Make sure we have up to date dead-var information
    java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
203
    pp_java   = PrintJava.compilationUnit java_code
204
#endif
205
\end{code}
206

207

rrt's avatar
rrt committed
208 209 210 211 212 213 214 215
%************************************************************************
%*									*
\subsection{Ilx}
%*									*
%************************************************************************

\begin{code}
#ifdef ILX
216 217
outputIlx dflags filename mod tycons stg_binds
  =  doOutput filename (\ f -> printForC f pp_ilx)
rrt's avatar
rrt committed
218 219 220 221 222 223
  where
    pp_ilx = ilxGen mod tycons stg_binds
#endif
\end{code}


224 225 226 227 228 229 230
%************************************************************************
%*									*
\subsection{Foreign import/export}
%*									*
%************************************************************************

\begin{code}
231 232 233
outputForeignStubs :: DynFlags -> ForeignStubs
		   -> IO (Bool, 	-- Header file created
			  Bool)		-- C file created
krc's avatar
krc committed
234 235 236 237 238 239
outputForeignStubs dflags NoStubs = do
-- When compiling External Core files, may need to use stub files from a 
-- previous compilation
   hFileExists <- doesFileExist (hscStubHOutName dflags)
   cFileExists <- doesFileExist (hscStubCOutName dflags)
   return (hFileExists, cFileExists)
240
outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
241
  = do
242
	dumpIfSet_dyn dflags Opt_D_dump_foreign
243 244
                      "Foreign export header file" stub_h_output_d

245 246 247 248 249
	-- we need the #includes from the rts package for the stub files
	rts_pkgs <- getPackageDetails [rtsPackage]
 	let rts_includes = concatMap mk_include (concatMap c_includes rts_pkgs)
	    mk_include i = "#include \"" ++ i ++ "\"\n"

250 251
	stub_h_file_exists
           <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
252
		("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
253

254
	dumpIfSet_dyn dflags Opt_D_dump_foreign
255 256
                      "Foreign export stubs" stub_c_output_d

257 258
	stub_c_file_exists
           <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
259
		("#define IN_STG_CODE 0\n" ++ 
260
		 "#include \"Rts.h\"\n" ++
261
		 rts_includes ++
262 263
		 cplusplus_hdr)
		 cplusplus_ftr
264
	   -- We're adding the default hc_header to the stub file, but this
265 266
	   -- isn't really HC code, so we need to define IN_STG_CODE==0 to
	   -- avoid the register variables etc. being enabled.
267 268

        return (stub_h_file_exists, stub_c_file_exists)
269
  where
270 271 272 273 274 275 276 277
    -- C stubs for "foreign export"ed functions.
    stub_c_output_d = pprCode CStyle c_code
    stub_c_output_w = showSDoc stub_c_output_d

    -- Header file protos for "foreign export"ed functions.
    stub_h_output_d = pprCode CStyle h_code
    stub_h_output_w = showSDoc stub_h_output_d

278 279
cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
280

281 282 283
-- Don't use doOutput for dumping the f. export stubs
-- since it is more than likely that the stubs file will
-- turn out to be empty, in which case no file should be created.
284 285 286
outputForeignStubs_help fname ""      header footer = return False
outputForeignStubs_help fname doc_str header footer
   = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
287
        return True
288 289
\end{code}