Replace createDirectoryHierarchy with createDirectoryIfMissing True
[ghc.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 import AsmCodeGen ( nativeCodeGen )
12 import LlvmCodeGen ( llvmCodeGen )
13
14 import UniqSupply       ( mkSplitUniqSupply )
15
16 import Finder           ( mkStubPaths )
17 import PprC             ( writeCs )
18 import CmmLint          ( cmmLint )
19 import Packages
20 import OldCmm           ( RawCmmGroup )
21 import HscTypes
22 import DynFlags
23 import Config
24 import SysTools
25
26 import ErrUtils         ( dumpIfSet_dyn, showPass, ghcExit )
27 import Outputable
28 import Module
29 import Maybes           ( firstJusts )
30
31 import Control.Exception
32 import Control.Monad
33 import System.Directory
34 import System.FilePath
35 import System.IO
36 \end{code}
37
38 %************************************************************************
39 %*                                                                      *
40 \subsection{Steering}
41 %*                                                                      *
42 %************************************************************************
43
44 \begin{code}
45 codeOutput :: DynFlags
46            -> Module
47            -> ModLocation
48            -> ForeignStubs
49            -> [PackageId]
50            -> [RawCmmGroup]                       -- Compiled C--
51            -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
52
53 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
54   = 
55     do  { when (dopt Opt_DoCmmLinting dflags) $ do
56                 { showPass dflags "CmmLint"
57                 ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
58                 ; case firstJusts lints of
59                         Just err -> do { printDump err
60                                        ; ghcExit dflags 1
61                                        }
62                         Nothing  -> return ()
63                 }
64
65         ; showPass dflags "CodeOutput"
66         ; let filenm = hscOutName dflags 
67         ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
68         ; case hscTarget dflags of {
69              HscInterpreted -> return ();
70              HscAsm         -> outputAsm dflags filenm flat_abstractC;
71              HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
72              HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
73              HscNothing     -> panic "codeOutput: HscNothing"
74           }
75         ; return stubs_exist
76         }
77
78 doOutput :: String -> (Handle -> IO ()) -> IO ()
79 doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
80 \end{code}
81
82
83 %************************************************************************
84 %*                                                                      *
85 \subsection{C}
86 %*                                                                      *
87 %************************************************************************
88
89 \begin{code}
90 outputC :: DynFlags
91         -> FilePath
92         -> [RawCmmGroup]
93         -> [PackageId]
94         -> IO ()
95
96 outputC dflags filenm flat_absC packages
97   = do 
98        -- figure out which header files to #include in the generated .hc file:
99        --
100        --   * extra_includes from packages
101        --   * -#include options from the cmdline and OPTIONS pragmas
102        --   * the _stub.h file, if there is one.
103        --
104        let rts = getPackageDetails (pkgState dflags) rtsPackageId
105                        
106        let cc_injects = unlines (map mk_include (includes rts))
107            mk_include h_file = 
108             case h_file of 
109                '"':_{-"-} -> "#include "++h_file
110                '<':_      -> "#include "++h_file
111                _          -> "#include \""++h_file++"\""
112
113        pkg_configs <- getPreloadPackagesAnd dflags packages
114        let pkg_names = map (display.sourcePackageId) pkg_configs
115
116        doOutput filenm $ \ h -> do
117           hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
118           hPutStr h cc_injects
119           writeCs dflags h flat_absC
120 \end{code}
121
122
123 %************************************************************************
124 %*                                                                      *
125 \subsection{Assembler}
126 %*                                                                      *
127 %************************************************************************
128
129 \begin{code}
130 outputAsm :: DynFlags -> FilePath -> [RawCmmGroup] -> IO ()
131 outputAsm dflags filenm flat_absC
132  | cGhcWithNativeCodeGen == "YES"
133   = do ncg_uniqs <- mkSplitUniqSupply 'n'
134
135        {-# SCC "OutputAsm" #-} doOutput filenm $
136            \f -> {-# SCC "NativeCodeGen" #-}
137                  nativeCodeGen dflags f ncg_uniqs flat_absC
138
139  | otherwise
140   = panic "This compiler was built without a native code generator"
141 \end{code}
142
143
144 %************************************************************************
145 %*                                                                      *
146 \subsection{LLVM}
147 %*                                                                      *
148 %************************************************************************
149
150 \begin{code}
151 outputLlvm :: DynFlags -> FilePath -> [RawCmmGroup] -> IO ()
152 outputLlvm dflags filenm flat_absC
153   = do ncg_uniqs <- mkSplitUniqSupply 'n'
154        {-# SCC "llvm_output" #-} doOutput filenm $
155            \f -> {-# SCC "llvm_CodeGen" #-}
156                  llvmCodeGen dflags f ncg_uniqs flat_absC
157 \end{code}
158
159
160 %************************************************************************
161 %*                                                                      *
162 \subsection{Foreign import/export}
163 %*                                                                      *
164 %************************************************************************
165
166 \begin{code}
167 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
168                    -> IO (Bool,         -- Header file created
169                           Maybe FilePath) -- C file created
170 outputForeignStubs dflags mod location stubs
171  = do
172    let stub_h = mkStubPaths dflags (moduleName mod) location
173    stub_c <- newTempName dflags "c"
174
175    case stubs of
176      NoStubs -> do
177         -- When compiling External Core files, may need to use stub
178         -- files from a previous compilation
179         stub_h_exists <- doesFileExist stub_h
180         return (stub_h_exists, Nothing)
181
182      ForeignStubs h_code c_code -> do
183         let
184             stub_c_output_d = pprCode CStyle c_code
185             stub_c_output_w = showSDoc stub_c_output_d
186         
187             -- Header file protos for "foreign export"ed functions.
188             stub_h_output_d = pprCode CStyle h_code
189             stub_h_output_w = showSDoc stub_h_output_d
190         -- in
191
192         createDirectoryIfMissing True (takeDirectory stub_h)
193
194         dumpIfSet_dyn dflags Opt_D_dump_foreign
195                       "Foreign export header file" stub_h_output_d
196
197         -- we need the #includes from the rts package for the stub files
198         let rts_includes = 
199                let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
200                concatMap mk_include (includes rts_pkg)
201             mk_include i = "#include \"" ++ i ++ "\"\n"
202
203             -- wrapper code mentions the ffi_arg type, which comes from ffi.h
204             ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"
205                          | otherwise = ""
206
207         stub_h_file_exists
208            <- outputForeignStubs_help stub_h stub_h_output_w
209                 ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
210
211         dumpIfSet_dyn dflags Opt_D_dump_foreign
212                       "Foreign export stubs" stub_c_output_d
213
214         stub_c_file_exists
215            <- outputForeignStubs_help stub_c stub_c_output_w
216                 ("#define IN_STG_CODE 0\n" ++ 
217                  "#include \"Rts.h\"\n" ++
218                  rts_includes ++
219                  ffi_includes ++
220                  cplusplus_hdr)
221                  cplusplus_ftr
222            -- We're adding the default hc_header to the stub file, but this
223            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
224            -- avoid the register variables etc. being enabled.
225
226         return (stub_h_file_exists, if stub_c_file_exists
227                                        then Just stub_c
228                                        else Nothing )
229  where
230    cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
231    cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
232
233
234 -- Don't use doOutput for dumping the f. export stubs
235 -- since it is more than likely that the stubs file will
236 -- turn out to be empty, in which case no file should be created.
237 outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
238 outputForeignStubs_help _fname ""      _header _footer = return False
239 outputForeignStubs_help fname doc_str header footer
240    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
241         return True
242 \end{code}
243