Remove unused imports
[ghc-hetmet.git] / compiler / main / CodeOutput.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4 \section{Code output phase}
5
6 \begin{code}
7 module CodeOutput( codeOutput, outputForeignStubs ) where
8
9 #include "HsVersions.h"
10
11 #ifndef OMIT_NATIVE_CODEGEN
12 import UniqSupply       ( mkSplitUniqSupply )
13 import AsmCodeGen       ( nativeCodeGen )
14 #endif
15
16 #ifdef JAVA
17 import JavaGen          ( javaGen )
18 import qualified PrintJava
19 import OccurAnal        ( occurAnalyseBinds )
20 #endif
21
22 import Finder           ( mkStubPaths )
23 import PprC             ( writeCs )
24 import CmmLint          ( cmmLint )
25 import Packages
26 import Util
27 import Cmm              ( RawCmm )
28 import HscTypes
29 import DynFlags
30
31 import ErrUtils         ( dumpIfSet_dyn, showPass, ghcExit )
32 import Outputable
33 import Module
34 import Maybes           ( firstJust )
35
36 import Directory        ( doesFileExist )
37 import Monad            ( when )
38 import IO
39 import System.FilePath
40 \end{code}
41
42 %************************************************************************
43 %*                                                                      *
44 \subsection{Steering}
45 %*                                                                      *
46 %************************************************************************
47
48 \begin{code}
49 codeOutput :: DynFlags
50            -> Module
51            -> ModLocation
52            -> ForeignStubs
53            -> [PackageId]
54            -> [RawCmm]                  -- Compiled C--
55            -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
56
57 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
58   = 
59     -- You can have C (c_output) or assembly-language (ncg_output),
60     -- but not both.  [Allowing for both gives a space leak on
61     -- flat_abstractC.  WDP 94/10]
62
63     -- Dunno if the above comment is still meaningful now.  JRS 001024.
64
65     do  { when (dopt Opt_DoCmmLinting dflags) $ do
66                 { showPass dflags "CmmLint"
67                 ; let lints = map cmmLint flat_abstractC
68                 ; case firstJust lints of
69                         Just err -> do { printDump err
70                                        ; ghcExit dflags 1
71                                        }
72                         Nothing  -> return ()
73                 }
74
75         ; showPass dflags "CodeOutput"
76         ; let filenm = hscOutName dflags 
77         ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
78         ; case hscTarget dflags of {
79              HscInterpreted -> return ();
80              HscAsm         -> outputAsm dflags filenm flat_abstractC;
81              HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
82              HscJava        -> 
83 #ifdef JAVA
84                                outputJava dflags filenm mod_name tycons core_binds;
85 #else
86                                panic "Java support not compiled into this ghc";
87 #endif
88              HscNothing     -> panic "codeOutput: HscNothing"
89           }
90         ; return stubs_exist
91         }
92
93 doOutput :: String -> (Handle -> IO ()) -> IO ()
94 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
95 \end{code}
96
97
98 %************************************************************************
99 %*                                                                      *
100 \subsection{C}
101 %*                                                                      *
102 %************************************************************************
103
104 \begin{code}
105 outputC :: DynFlags
106         -> FilePath
107         -> [RawCmm]
108         -> [PackageId]
109         -> IO ()
110
111 outputC dflags filenm flat_absC packages
112   = do 
113        -- figure out which header files to #include in the generated .hc file:
114        --
115        --   * extra_includes from packages
116        --   * -#include options from the cmdline and OPTIONS pragmas
117        --   * the _stub.h file, if there is one.
118        --
119        let rts = getPackageDetails (pkgState dflags) rtsPackageId
120                        
121        let cc_injects = unlines (map mk_include (includes rts))
122            mk_include h_file = 
123             case h_file of 
124                '"':_{-"-} -> "#include "++h_file
125                '<':_      -> "#include "++h_file
126                _          -> "#include \""++h_file++"\""
127
128        pkg_configs <- getPreloadPackagesAnd dflags packages
129        let pkg_names = map (display.package) pkg_configs
130
131        doOutput filenm $ \ h -> do
132           hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
133           hPutStr h cc_injects
134           writeCs dflags h flat_absC
135 \end{code}
136
137
138 %************************************************************************
139 %*                                                                      *
140 \subsection{Assembler}
141 %*                                                                      *
142 %************************************************************************
143
144 \begin{code}
145 outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
146
147 #ifndef OMIT_NATIVE_CODEGEN
148
149 outputAsm dflags filenm flat_absC
150   = do ncg_uniqs <- mkSplitUniqSupply 'n'
151
152        {-# SCC "OutputAsm" #-} doOutput filenm $
153            \f -> {-# SCC "NativeCodeGen" #-}
154                  nativeCodeGen dflags f ncg_uniqs flat_absC
155   where
156
157 #else /* OMIT_NATIVE_CODEGEN */
158
159 outputAsm _ _ _
160   = pprPanic "This compiler was built without a native code generator"
161              (text "Use -fvia-C instead")
162
163 #endif
164 \end{code}
165
166
167 %************************************************************************
168 %*                                                                      *
169 \subsection{Java}
170 %*                                                                      *
171 %************************************************************************
172
173 \begin{code}
174 #ifdef JAVA
175 outputJava dflags filenm mod tycons core_binds
176   = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
177         -- User style printing for now to keep indentation
178   where
179     occ_anal_binds = occurAnalyseBinds core_binds
180         -- Make sure we have up to date dead-var information
181     java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
182     pp_java   = PrintJava.compilationUnit java_code
183 #endif
184 \end{code}
185
186
187 %************************************************************************
188 %*                                                                      *
189 \subsection{Foreign import/export}
190 %*                                                                      *
191 %************************************************************************
192
193 \begin{code}
194 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
195                    -> IO (Bool,         -- Header file created
196                           Bool)         -- C file created
197 outputForeignStubs dflags mod location stubs
198  = case stubs of
199    NoStubs -> do
200         -- When compiling External Core files, may need to use stub
201         -- files from a previous compilation
202         stub_c_exists <- doesFileExist stub_c
203         stub_h_exists <- doesFileExist stub_h
204         return (stub_h_exists, stub_c_exists)
205
206    ForeignStubs h_code c_code -> do
207         let
208             stub_c_output_d = pprCode CStyle c_code
209             stub_c_output_w = showSDoc stub_c_output_d
210         
211             -- Header file protos for "foreign export"ed functions.
212             stub_h_output_d = pprCode CStyle h_code
213             stub_h_output_w = showSDoc stub_h_output_d
214         -- in
215
216         createDirectoryHierarchy (takeDirectory stub_c)
217
218         dumpIfSet_dyn dflags Opt_D_dump_foreign
219                       "Foreign export header file" stub_h_output_d
220
221         -- we need the #includes from the rts package for the stub files
222         let rts_includes = 
223                let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
224                concatMap mk_include (includes rts_pkg)
225             mk_include i = "#include \"" ++ i ++ "\"\n"
226
227         stub_h_file_exists
228            <- outputForeignStubs_help stub_h stub_h_output_w
229                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
230
231         dumpIfSet_dyn dflags Opt_D_dump_foreign
232                       "Foreign export stubs" stub_c_output_d
233
234         stub_c_file_exists
235            <- outputForeignStubs_help stub_c stub_c_output_w
236                 ("#define IN_STG_CODE 0\n" ++ 
237                  "#include \"Rts.h\"\n" ++
238                  rts_includes ++
239                  cplusplus_hdr)
240                  cplusplus_ftr
241            -- We're adding the default hc_header to the stub file, but this
242            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
243            -- avoid the register variables etc. being enabled.
244
245         return (stub_h_file_exists, stub_c_file_exists)
246   where
247    (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location
248
249    cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
250    cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
251
252
253 -- Don't use doOutput for dumping the f. export stubs
254 -- since it is more than likely that the stubs file will
255 -- turn out to be empty, in which case no file should be created.
256 outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
257 outputForeignStubs_help _fname ""      _header _footer = return False
258 outputForeignStubs_help fname doc_str header footer
259    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
260         return True
261 \end{code}
262