Teach vectorisation about Double
[ghc-hetmet.git] / compiler / main / DriverMkDepend.hs
1 {-# OPTIONS -w #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
6 -- for details
7
8 -----------------------------------------------------------------------------
9 --
10 -- Makefile Dependency Generation
11 --
12 -- (c) The University of Glasgow 2005
13 --
14 -----------------------------------------------------------------------------
15
16 module DriverMkDepend (
17         doMkDependHS
18   ) where
19
20 #include "HsVersions.h"
21
22 import qualified GHC
23 import GHC              ( Session, ModSummary(..) )
24 import DynFlags
25 import Util             ( escapeSpaces, splitFilename, joinFileExt )
26 import HscTypes         ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath )
27 import SysTools         ( newTempName )
28 import qualified SysTools
29 import Module
30 import Digraph          ( SCC(..) )
31 import Finder           ( findImportedModule, FindResult(..) )
32 import Util             ( global, consIORef )
33 import Outputable
34 import Panic
35 import SrcLoc
36 import Data.List
37 import CmdLineParser
38
39 import ErrUtils         ( debugTraceMsg, putMsg )
40
41 import Data.IORef       ( IORef, readIORef, writeIORef )
42 import Control.Exception
43 import System.Exit      ( ExitCode(..), exitWith )
44 import System.Directory
45 import System.IO
46 import SYSTEM_IO_ERROR  ( isEOFError )
47 import Control.Monad    ( when )
48 import Data.Maybe       ( isJust )
49
50 -----------------------------------------------------------------
51 --
52 --              The main function
53 --
54 -----------------------------------------------------------------
55
56 doMkDependHS :: Session -> [FilePath] -> IO ()
57 doMkDependHS session srcs
58   = do  {       -- Initialisation
59           dflags <- GHC.getSessionDynFlags session
60         ; files <- beginMkDependHS dflags
61
62                 -- Do the downsweep to find all the modules
63         ; targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
64         ; GHC.setTargets session targets
65         ; excl_mods <- readIORef v_Dep_exclude_mods
66         ; r <- GHC.depanal session excl_mods True {- Allow dup roots -}
67         ; case r of
68             Nothing -> exitWith (ExitFailure 1)
69             Just mod_summaries -> do {
70
71                 -- Sort into dependency order
72                 -- There should be no cycles
73           let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
74
75                 -- Print out the dependencies if wanted
76         ; debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
77
78                 -- Prcess them one by one, dumping results into makefile
79                 -- and complaining about cycles
80         ; mapM (processDeps session excl_mods (mkd_tmp_hdl files)) sorted
81
82                 -- If -ddump-mod-cycles, show cycles in the module graph
83         ; dumpModCycles dflags mod_summaries
84
85                 -- Tidy up
86         ; endMkDependHS dflags files }}
87
88 -----------------------------------------------------------------
89 --
90 --              beginMkDependHs
91 --      Create a temporary file, 
92 --      find the Makefile, 
93 --      slurp through it, etc
94 --
95 -----------------------------------------------------------------
96
97 data MkDepFiles 
98   = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile
99             mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile 
100             mkd_tmp_file  :: FilePath,          -- Name of the temporary file
101             mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file
102
103 beginMkDependHS :: DynFlags -> IO MkDepFiles
104         
105 beginMkDependHS dflags = do
106         -- slurp in the mkdependHS-style options
107   let flags = getOpts dflags opt_dep
108   _ <- processArgs dep_opts flags
109
110         -- open a new temp file in which to stuff the dependency info
111         -- as we go along.
112   tmp_file <- newTempName dflags "dep"
113   tmp_hdl <- openFile tmp_file WriteMode
114
115         -- open the makefile
116   makefile <- readIORef v_Dep_makefile
117   exists <- doesFileExist makefile
118   mb_make_hdl <- 
119         if not exists
120         then return Nothing
121         else do
122            makefile_hdl <- openFile makefile ReadMode
123
124                 -- slurp through until we get the magic start string,
125                 -- copying the contents into dep_makefile
126            let slurp = do
127                 l <- hGetLine makefile_hdl
128                 if (l == depStartMarker)
129                         then return ()
130                         else do hPutStrLn tmp_hdl l; slurp
131          
132                 -- slurp through until we get the magic end marker,
133                 -- throwing away the contents
134            let chuck = do
135                 l <- hGetLine makefile_hdl
136                 if (l == depEndMarker)
137                         then return ()
138                         else chuck
139          
140            catchJust ioErrors slurp 
141                 (\e -> if isEOFError e then return () else ioError e)
142            catchJust ioErrors chuck
143                 (\e -> if isEOFError e then return () else ioError e)
144
145            return (Just makefile_hdl)
146
147
148         -- write the magic marker into the tmp file
149   hPutStrLn tmp_hdl depStartMarker
150
151   return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, 
152                   mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})
153
154
155 -----------------------------------------------------------------
156 --
157 --              processDeps
158 --
159 -----------------------------------------------------------------
160
161 processDeps :: Session
162             -> [ModuleName]
163             -> Handle           -- Write dependencies to here
164             -> SCC ModSummary
165             -> IO ()
166 -- Write suitable dependencies to handle
167 -- Always:
168 --                      this.o : this.hs
169 --
170 -- If the dependency is on something other than a .hi file:
171 --                      this.o this.p_o ... : dep
172 -- otherwise
173 --                      this.o ...   : dep.hi
174 --                      this.p_o ... : dep.p_hi
175 --                      ...
176 -- (where .o is $osuf, and the other suffixes come from
177 -- the cmdline -s options).
178 --
179 -- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
180
181 processDeps session excl_mods hdl (CyclicSCC nodes)
182   =     -- There shouldn't be any cycles; report them   
183     throwDyn (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes))
184
185 processDeps session excl_mods hdl (AcyclicSCC node)
186   = do  { extra_suffixes   <- readIORef v_Dep_suffixes
187         ; hsc_env <- GHC.sessionHscEnv session
188         ; include_pkg_deps <- readIORef v_Dep_include_pkg_deps
189         ; let src_file  = msHsFilePath node
190               obj_file  = msObjFilePath node
191               obj_files = insertSuffixes obj_file extra_suffixes
192
193               do_imp is_boot imp_mod
194                 = do { mb_hi <- findDependency hsc_env src_file imp_mod 
195                                                is_boot include_pkg_deps
196                      ; case mb_hi of {
197                            Nothing      -> return () ;
198                            Just hi_file -> do
199                      { let hi_files = insertSuffixes hi_file extra_suffixes
200                            write_dep (obj,hi) = writeDependency hdl [obj] hi
201
202                         -- Add one dependency for each suffix; 
203                         -- e.g.         A.o   : B.hi
204                         --              A.x_o : B.x_hi
205                      ; mapM_ write_dep (obj_files `zip` hi_files) }}}
206
207              
208                 -- Emit std dependency of the object(s) on the source file
209                 -- Something like       A.o : A.hs
210         ; writeDependency hdl obj_files src_file
211
212                 -- Emit a dependency for each import
213
214         -- SOURCE imports
215         ; mapM_ (do_imp True)  
216                 (filter (`notElem` excl_mods) (map unLoc (ms_srcimps node)))
217
218         -- regular imports
219         ; mapM_ (do_imp False)
220                 (filter (`notElem` excl_mods) (map unLoc (ms_imps node)))
221         }
222
223
224 findDependency  :: HscEnv
225                 -> FilePath             -- Importing module: used only for error msg
226                 -> ModuleName           -- Imported module
227                 -> IsBootInterface      -- Source import
228                 -> Bool                 -- Record dependency on package modules
229                 -> IO (Maybe FilePath)  -- Interface file file
230 findDependency hsc_env src imp is_boot include_pkg_deps
231   = do  {       -- Find the module; this will be fast because
232                 -- we've done it once during downsweep
233           r <- findImportedModule hsc_env imp Nothing
234         ; case r of 
235             Found loc mod
236                 -- Home package: just depend on the .hi or hi-boot file
237                 | isJust (ml_hs_file loc)
238                 -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
239
240                 -- Not in this package: we don't need a dependency
241                 | otherwise
242                 -> return Nothing
243
244             _ -> panic "findDependency"
245         }
246
247 -----------------------------
248 writeDependency :: Handle -> [FilePath] -> FilePath -> IO ()
249 -- (writeDependency h [t1,t2] dep) writes to handle h the dependency
250 --      t1 t2 : dep
251 writeDependency hdl targets dep
252   = hPutStrLn hdl (unwords (map escapeSpaces targets) ++ " : "
253                    ++ escapeSpaces dep)
254
255 -----------------------------
256 insertSuffixes  
257         :: FilePath     -- Original filename;   e.g. "foo.o"
258         -> [String]     -- Extra suffices       e.g. ["x","y"]
259         -> [FilePath]   -- Zapped filenames     e.g. ["foo.o", "foo.x_o", "foo.y_o"]
260         -- Note that that the extra bit gets inserted *before* the old suffix
261         -- We assume the old suffix contains no dots, so we can strip it with removeSuffix
262
263         -- NOTE: we used to have this comment
264                 -- In order to construct hi files with alternate suffixes, we
265                 -- now have to find the "basename" of the hi file.  This is
266                 -- difficult because we can't just split the hi filename
267                 -- at the last dot - the hisuf might have dots in it.  So we
268                 -- check whether the hi filename ends in hisuf, and if it does,
269                 -- we strip off hisuf, otherwise we strip everything after the
270                 -- last dot.
271         -- But I'm not sure we care about hisufs with dots in them. 
272         -- Lots of other things will break first!
273
274 insertSuffixes file_name extras
275   = file_name : [ basename `joinFileExt` (extra ++ "_" ++ suffix) | extra <- extras ]
276   where
277     (basename, suffix) = splitFilename file_name
278
279
280 -----------------------------------------------------------------
281 --
282 --              endMkDependHs
283 --      Complete the makefile, close the tmp file etc
284 --
285 -----------------------------------------------------------------
286
287 endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
288
289 endMkDependHS dflags 
290    (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,
291             mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl }) 
292   = do
293   -- write the magic marker into the tmp file
294   hPutStrLn tmp_hdl depEndMarker
295
296   case makefile_hdl of
297      Nothing  -> return ()
298      Just hdl -> do
299
300           -- slurp the rest of the original makefile and copy it into the output
301         let slurp = do
302                 l <- hGetLine hdl
303                 hPutStrLn tmp_hdl l
304                 slurp
305          
306         catchJust ioErrors slurp 
307                 (\e -> if isEOFError e then return () else ioError e)
308
309         hClose hdl
310
311   hClose tmp_hdl  -- make sure it's flushed
312
313         -- Create a backup of the original makefile
314   when (isJust makefile_hdl)
315        (SysTools.copy dflags ("Backing up " ++ makefile) 
316           makefile (makefile++".bak"))
317
318         -- Copy the new makefile in place
319   SysTools.copy dflags "Installing new makefile" tmp_file makefile
320
321
322 -----------------------------------------------------------------
323 --              Module cycles
324 -----------------------------------------------------------------
325
326 dumpModCycles :: DynFlags -> [ModSummary] -> IO ()
327 dumpModCycles dflags mod_summaries
328   | not (dopt Opt_D_dump_mod_cycles dflags) 
329   = return ()
330
331   | null cycles
332   = putMsg dflags (ptext SLIT("No module cycles"))
333
334   | otherwise
335   = putMsg dflags (hang (ptext SLIT("Module cycles found:")) 2 pp_cycles)
336   where
337
338     cycles :: [[ModSummary]]
339     cycles = [ c | CyclicSCC c <- GHC.topSortModuleGraph True mod_summaries Nothing ]
340
341     pp_cycles = vcat [ (ptext SLIT("---------- Cycle") <+> int n <+> ptext SLIT("----------")) 
342                         $$ pprCycle c $$ text ""
343                      | (n,c) <- [1..] `zip` cycles ]
344
345 pprCycle :: [ModSummary] -> SDoc
346 -- Print a cycle, but show only the imports within the cycle
347 pprCycle summaries = pp_group (CyclicSCC summaries)
348   where
349     cycle_mods :: [ModuleName]  -- The modules in this cycle
350     cycle_mods = map (moduleName . ms_mod) summaries
351
352     pp_group (AcyclicSCC ms) = pp_ms ms
353     pp_group (CyclicSCC mss) 
354         = ASSERT( not (null boot_only) )
355                 -- The boot-only list must be non-empty, else there would
356                 -- be an infinite chain of non-boot imoprts, and we've
357                 -- already checked for that in processModDeps
358           pp_ms loop_breaker $$ vcat (map pp_group groups)
359         where
360           (boot_only, others) = partition is_boot_only mss
361           is_boot_only ms = not (any in_group (ms_imps ms))
362           in_group (L _ m) = m `elem` group_mods
363           group_mods = map (moduleName . ms_mod) mss
364           
365           loop_breaker = head boot_only
366           all_others   = tail boot_only ++ others
367           groups = GHC.topSortModuleGraph True all_others Nothing
368
369     pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
370                        <+> (pp_imps empty (ms_imps summary) $$
371                             pp_imps (ptext SLIT("{-# SOURCE #-}")) (ms_srcimps summary))
372         where
373           mod_str = moduleNameString (moduleName (ms_mod summary))
374
375     pp_imps :: SDoc -> [Located ModuleName] -> SDoc
376     pp_imps what [] = empty
377     pp_imps what lms 
378         = case [m | L _ m <- lms, m `elem` cycle_mods] of
379             [] -> empty
380             ms -> what <+> ptext SLIT("imports") <+> 
381                                 pprWithCommas ppr ms
382
383 -----------------------------------------------------------------
384 --
385 --              Flags
386 --
387 -----------------------------------------------------------------
388
389         -- Flags
390 GLOBAL_VAR(v_Dep_makefile,              "Makefile", String);
391 GLOBAL_VAR(v_Dep_include_pkg_deps,      False, Bool);
392 GLOBAL_VAR(v_Dep_exclude_mods,          [], [ModuleName]);
393 GLOBAL_VAR(v_Dep_suffixes,              [], [String]);
394 GLOBAL_VAR(v_Dep_warnings,              True, Bool);
395
396 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
397 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
398
399 -- for compatibility with the old mkDependHS, we accept options of the form
400 -- -optdep-f -optdep.depend, etc.
401 dep_opts = 
402    [ (  "s",                    SepArg (consIORef v_Dep_suffixes) )
403    , (  "f",                    SepArg (writeIORef v_Dep_makefile) )
404    , (  "w",                    NoArg (writeIORef v_Dep_warnings False) )
405
406    , (  "-include-prelude",     NoArg (writeIORef v_Dep_include_pkg_deps True) )
407         -- -include-prelude is the old name for -include-pkg-deps, kept around
408         -- for backward compatibility, but undocumented
409
410    , (  "-include-pkg-deps",    NoArg (writeIORef v_Dep_include_pkg_deps True) )
411    , (  "-exclude-module=",     Prefix (consIORef v_Dep_exclude_mods . mkModuleName) )
412    , (  "x",                    Prefix (consIORef v_Dep_exclude_mods . mkModuleName) )
413    ]