[project @ 2000-06-29 13:08:59 by simonmar]
[ghc-hetmet.git] / ghc / driver / Main.hs
1 -----------------------------------------------------------------------------
2 -- GHC Driver program
3 --
4 -- (c) Simon Marlow 2000
5 --
6 -----------------------------------------------------------------------------
7
8 module Main (main) where
9
10 import Package
11 import Config
12
13 import RegexString
14 import Concurrent
15 import Posix
16 import IOExts
17 import Exception
18 import Dynamic
19
20 import IO
21 import Array
22 import List
23 import System
24 import Maybe
25 import Char
26
27 #define GLOBAL_VAR(name,value,ty)  \
28 name = global (value) :: IORef (ty); \
29 {-# NOINLINE name #-}
30
31 -----------------------------------------------------------------------------
32 -- ToDo:
33
34 -- time commands when run with -v
35 -- split marker
36 -- mkDLL
37 -- java generation
38 -- user ways
39 -- Win32 support
40 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
41
42 -----------------------------------------------------------------------------
43 -- Differences vs. old driver:
44
45 -- No more "Enter your Haskell program, end with ^D (on a line of its own):"
46 -- consistency checking removed (may do this properly later)
47 -- removed -noC
48 -- no hi diffs (could be added later)
49 -- no -Ofile
50
51 -----------------------------------------------------------------------------
52 -- non-configured things
53
54 _Haskell1Version = "5" -- i.e., Haskell 98
55
56 -----------------------------------------------------------------------------
57 -- Usage Message
58
59 short_usage = do
60   hPutStr stderr "\nUsage: For basic information, try the `-help' option.\n"
61   exitWith ExitSuccess
62    
63 long_usage = do
64   let usage_dir = findFile "ghc-usage.txt" (cGHC_DRIVER_DIR++"/ghc-usage.txt")
65   usage <- readFile (usage_dir++"/ghc-usage.txt")
66   dump usage
67   exitWith ExitSuccess
68   where
69      dump "" = return ()
70      dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
71      dump (c:s) = hPutChar stderr c >> dump s
72
73 version_str = cProjectVersion ++ 
74                 ( if cProjectPatchLevel /= "0" && cProjectPatchLevel /= ""
75                         then '.':cProjectPatchLevel
76                         else "")
77
78 -----------------------------------------------------------------------------
79 -- Phases
80
81 {-
82 Phase of the           | Suffix saying | Flag saying   | (suffix of)
83 compilation system     | ``start here''| ``stop after''| output file
84
85 literate pre-processor | .lhs          | -             | -
86 C pre-processor (opt.) | -             | -E            | -
87 Haskell compiler       | .hs           | -C, -S        | .hc, .s
88 C compiler (opt.)      | .hc or .c     | -S            | .s
89 assembler              | .s  or .S     | -c            | .o
90 linker                 | other         | -             | a.out
91 -}
92
93 data Phase 
94         = MkDependHS    -- haskell dependency generation
95         | Unlit
96         | Cpp
97         | Hsc
98         | Cc
99         | HCc           -- Haskellised C (as opposed to vanilla C) compilation
100         | Mangle        -- assembly mangling, now done by a separate script.
101         | SplitMangle   -- after mangler if splitting
102         | SplitAs
103         | As
104         | Ln 
105   deriving (Eq,Ord,Enum,Ix,Show,Bounded)
106
107 initial_phase = Unlit
108
109 -----------------------------------------------------------------------------
110 -- Errors
111
112 data BarfKind
113   = UnknownFileType String
114   | UnknownFlag String
115   | AmbiguousPhase
116   | MultipleSrcsOneOutput
117   | UnknownPackage String
118   | WayCombinationNotSupported [WayName]
119   | PhaseFailed String ExitCode
120   | Interrupted
121   | NoInputFiles
122   deriving Eq
123
124 GLOBAL_VAR(prog_name, "ghc", String)
125
126 get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
127
128 instance Show BarfKind where
129   showsPrec _ e 
130         = showString get_prog_name . showString ": " . showBarf e
131
132 showBarf AmbiguousPhase
133    = showString "only one of the flags -M, -E, -C, -S, -c is allowed"
134 showBarf (UnknownFileType s)
135    = showString "unknown file type, and linking not done: " . showString s
136 showBarf (UnknownFlag s)
137    = showString "unrecognised flag: " . showString s
138 showBarf MultipleSrcsOneOutput
139    = showString "can't apply -o option to multiple source files"
140 showBarf (UnknownPackage s)
141    = showString "unknown package name: " . showString s
142 showBarf (WayCombinationNotSupported ws)
143    = showString "combination not supported: " 
144    . foldr1 (\a b -> a . showChar '/' . b) 
145         (map (showString . wayName . lkupWay) ws)
146 showBarf (NoInputFiles)
147    = showString "no input files"
148
149 barfKindTc = mkTyCon "BarfKind"
150
151 instance Typeable BarfKind where
152   typeOf _ = mkAppTy barfKindTc []
153
154 -----------------------------------------------------------------------------
155 -- Temporary files
156
157 GLOBAL_VAR(files_to_clean, [], [String])
158
159 cleanTempFiles :: IO ()
160 cleanTempFiles = do
161   fs <- readIORef files_to_clean
162   verb <- readIORef verbose
163
164   let blowAway f =
165            (do  on verb (hPutStrLn stderr ("removing: " ++ f))
166                 if '*' `elem` f then system ("rm -f " ++ f) >> return ()
167                                 else removeLink f)
168             `catchAllIO`
169            (\e -> on verb (hPutStrLn stderr 
170                                 ("warning: can't remove tmp file" ++ f)))
171   mapM_ blowAway fs
172
173 -----------------------------------------------------------------------------
174 -- Which phase to stop at
175
176 GLOBAL_VAR(stop_after, Ln, Phase)
177
178 end_phase_flag :: String -> Maybe Phase
179 end_phase_flag "-M" = Just MkDependHS
180 end_phase_flag "-E" = Just Cpp
181 end_phase_flag "-C" = Just Hsc
182 end_phase_flag "-S" = Just Mangle
183 end_phase_flag "-c" = Just As
184 end_phase_flag _    = Nothing
185
186 getStopAfter :: [String]
187          -> IO ( [String]   -- rest of command line
188                , Phase      -- stop after phase
189                , Bool       -- do linking?
190                )
191 getStopAfter flags 
192   = case my_partition end_phase_flag flags of
193         ([]   , rest) -> return (rest, As,  True)
194         ([one], rest) -> return (rest, one, False)
195         (_    , rest) -> throwDyn AmbiguousPhase
196
197 -----------------------------------------------------------------------------
198 -- Global compilation flags
199
200         -- Cpp-related flags
201 GLOBAL_VAR(cpp_flag, False, Bool)
202 hs_source_cpp_opts = global
203         [ "-D__HASKELL1__="++_Haskell1Version
204         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt                          
205         , "-D__HASKELL98__"
206         , "-D__CONCURRENT_HASKELL__"
207         ]
208
209         -- Keep output from intermediate phases
210 GLOBAL_VAR(keep_hi_diffs,       False,          Bool)
211 GLOBAL_VAR(keep_hc_files,       False,          Bool)
212 GLOBAL_VAR(keep_s_files,        False,          Bool)
213 GLOBAL_VAR(keep_raw_s_files,    False,          Bool)
214
215         -- Compiler RTS options
216 GLOBAL_VAR(specific_heap_size,  6 * 1000 * 1000, Integer)
217 GLOBAL_VAR(specific_stack_size, 1000 * 1000,     Integer)
218 GLOBAL_VAR(scale_sizes_by,      1.0,             Double)
219
220         -- Verbose
221 GLOBAL_VAR(verbose, False, Bool)
222 is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
223
224         -- Misc
225 GLOBAL_VAR(dry_run,             False,          Bool)
226 GLOBAL_VAR(recomp,              True,           Bool)
227 GLOBAL_VAR(tmp_prefix,          cTMPDIR,        String)
228 GLOBAL_VAR(stolen_x86_regs,     4,              Int)
229 GLOBAL_VAR(static,              True,           Bool)  -- ToDo: not for mingw32
230 GLOBAL_VAR(collect_ghc_timing,  False,          Bool)
231 GLOBAL_VAR(do_asm_mangling,     True,           Bool)
232
233 -----------------------------------------------------------------------------
234 -- Splitting object files (for libraries)
235
236 GLOBAL_VAR(split_object_files,  False,          Bool)
237 GLOBAL_VAR(split_prefix,        "",             String)
238 GLOBAL_VAR(n_split_files,       0,              Int)
239         
240 can_split :: Bool
241 can_split =  prefixMatch "i386" cTARGETPLATFORM
242           || prefixMatch "alpha" cTARGETPLATFORM
243           || prefixMatch "hppa" cTARGETPLATFORM
244           || prefixMatch "m68k" cTARGETPLATFORM
245           || prefixMatch "mips" cTARGETPLATFORM
246           || prefixMatch "powerpc" cTARGETPLATFORM
247           || prefixMatch "rs6000" cTARGETPLATFORM
248           || prefixMatch "sparc" cTARGETPLATFORM
249
250 -----------------------------------------------------------------------------
251 -- Compiler output options
252
253 data HscLang
254   = HscC
255   | HscAsm
256   | HscJava
257
258 GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" && 
259                          prefixMatch "i386" cTARGETPLATFORM
260                         then  HscAsm
261                         else  HscC, 
262            HscLang)
263
264 GLOBAL_VAR(output_dir,  Nothing, Maybe String)
265 GLOBAL_VAR(output_suf,  Nothing, Maybe String)
266 GLOBAL_VAR(output_file, Nothing, Maybe String)
267 GLOBAL_VAR(output_hi,   Nothing, Maybe String)
268
269 GLOBAL_VAR(ld_inputs,   [],      [String])
270
271 odir_ify :: String -> IO String
272 odir_ify f = do
273   odir_opt <- readIORef output_dir
274   case odir_opt of
275         Nothing -> return f
276         Just d  -> return (newdir d f)
277
278 osuf_ify :: String -> IO String
279 osuf_ify f = do
280   osuf_opt <- readIORef output_suf
281   case osuf_opt of
282         Nothing -> return f
283         Just s  -> return (newsuf s f)
284
285 -----------------------------------------------------------------------------
286 -- Hi Files
287
288 GLOBAL_VAR(produceHi,           True,   Bool)
289 GLOBAL_VAR(hi_on_stdout,        False,  Bool)
290 GLOBAL_VAR(hi_with,             "",     String)
291 GLOBAL_VAR(hi_suf,              "hi",   String)
292
293 data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs
294 GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag)
295
296 -----------------------------------------------------------------------------
297 -- Warnings & sanity checking
298
299 -- Warning packages that are controlled by -W and -Wall.  The 'standard'
300 -- warnings that you get all the time are
301 --         
302 --         -fwarn-overlapping-patterns
303 --         -fwarn-missing-methods
304 --         -fwarn-missing-fields
305 --         -fwarn-deprecations
306 --         -fwarn-duplicate-exports
307 -- 
308 -- these are turned off by -Wnot.
309
310 standardWarnings  = [ "-fwarn-overlapping-patterns"
311                     , "-fwarn-missing-methods"
312                     , "-fwarn-missing-fields"
313                     , "-fwarn-deprecations"
314                     , "-fwarn-duplicate-exports"
315                     ]
316 minusWOpts        = standardWarnings ++ 
317                     [ "-fwarn-unused-binds"
318                     , "-fwarn-unused-matches"
319                     , "-fwarn-incomplete-patterns"
320                     , "-fwarn-unused-imports"
321                     ]
322 minusWallOpts     = minusWOpts ++
323                     [ "-fwarn-type-defaults"
324                     , "-fwarn-name-shadowing"
325                     , "-fwarn-missing-signatures"
326                     ]
327
328 data WarningState = W_default | W_ | W_all | W_not
329
330 GLOBAL_VAR(warning_opt, W_default, WarningState)
331
332 -----------------------------------------------------------------------------
333 -- Compiler optimisation options
334
335 GLOBAL_VAR(opt_level, 0, Int)
336
337 setOptLevel :: String -> IO ()
338 setOptLevel ""              = do { writeIORef opt_level 1; go_via_C }
339 setOptLevel "not"           = writeIORef opt_level 0
340 setOptLevel [c] | isDigit c = do
341    let level = ord c - ord '0'
342    writeIORef opt_level level
343    on (level >= 1) go_via_C
344 setOptLevel s = throwDyn (UnknownFlag ("-O"++s))
345
346 go_via_C = do
347    l <- readIORef hsc_lang
348    case l of { HscAsm -> writeIORef hsc_lang HscC; 
349                _other -> return () }
350
351 GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
352
353 GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
354 GLOBAL_VAR(opt_StgStats,    False, Bool)
355 GLOBAL_VAR(opt_UsageSPInf,  False, Bool)  -- Off by default
356
357 hsc_minusO2_flags = hsc_minusO_flags    -- for now
358
359 hsc_minusNoO_flags = do
360   iter        <- readIORef opt_MaxSimplifierIterations
361   return [ 
362         "-fignore-interface-pragmas",
363         "-fomit-interface-pragmas",
364         "-fsimplify",
365             "[",
366                 "-fmax-simplifier-iterations" ++ show iter,
367             "]"
368         ]
369
370 hsc_minusO_flags = do
371   iter       <- readIORef opt_MaxSimplifierIterations
372   usageSP    <- readIORef opt_UsageSPInf
373   stgstats   <- readIORef opt_StgStats
374
375   return [ 
376         "-ffoldr-build-on",
377
378         "-fdo-eta-reduction",
379         "-fdo-lambda-eta-expansion",
380         "-fcase-of-case",
381         "-fcase-merge",
382         "-flet-to-case",
383
384         -- initial simplify: mk specialiser happy: minimum effort please
385
386         "-fsimplify",
387           "[", 
388                 "-finline-phase0",
389                         -- Don't inline anything till full laziness has bitten
390                         -- In particular, inlining wrappers inhibits floating
391                         -- e.g. ...(case f x of ...)...
392                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
393                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
394                         -- and now the redex (f x) isn't floatable any more
395
396                 "-fno-rules",
397                         -- Similarly, don't apply any rules until after full 
398                         -- laziness.  Notably, list fusion can prevent floating.
399
400                 "-fno-case-of-case",
401                         -- Don't do case-of-case transformations.
402                         -- This makes full laziness work better
403
404                 "-fmax-simplifier-iterations2",
405           "]",
406
407         -- Specialisation is best done before full laziness
408         -- so that overloaded functions have all their dictionary lambdas manifest
409         "-fspecialise",
410
411         "-ffloat-outwards",
412         "-ffloat-inwards",
413
414         "-fsimplify",
415           "[", 
416                 "-finline-phase1",
417                 -- Want to run with inline phase 1 after the specialiser to give
418                 -- maximum chance for fusion to work before we inline build/augment
419                 -- in phase 2.  This made a difference in 'ansi' where an 
420                 -- overloaded function wasn't inlined till too late.
421                 "-fmax-simplifier-iterations" ++ show iter,
422           "]",
423
424         -- infer usage information here in case we need it later.
425         -- (add more of these where you need them --KSW 1999-04)
426         if usageSP then "-fusagesp" else "",
427
428         "-fsimplify",
429           "[", 
430                 -- Need inline-phase2 here so that build/augment get 
431                 -- inlined.  I found that spectral/hartel/genfft lost some useful
432                 -- strictness in the function sumcode' if augment is not inlined
433                 -- before strictness analysis runs
434
435                 "-finline-phase2",
436                 "-fmax-simplifier-iterations2",
437           "]",
438
439
440         "-fsimplify",
441           "[", 
442                 "-fmax-simplifier-iterations2",
443                 -- No -finline-phase: allow all Ids to be inlined now
444                 -- This gets foldr inlined before strictness analysis
445           "]",
446
447         "-fstrictness",
448         "-fcpr-analyse",
449         "-fworker-wrapper",
450
451         "-fsimplify",
452           "[", 
453                 "-fmax-simplifier-iterations" ++ show iter,
454                 -- No -finline-phase: allow all Ids to be inlined now
455           "]",
456
457         "-ffloat-outwards",
458                 -- nofib/spectral/hartel/wang doubles in speed if you
459                 -- do full laziness late in the day.  It only happens
460                 -- after fusion and other stuff, so the early pass doesn't
461                 -- catch it.  For the record, the redex is 
462                 --        f_el22 (f_el21 r_midblock)
463
464 -- Leave out lambda lifting for now
465 --        "-fsimplify", -- Tidy up results of full laziness
466 --          "[", 
467 --                "-fmax-simplifier-iterations2",
468 --          "]",
469 --        "-ffloat-outwards-full",      
470
471         -- We want CSE to follow the final full-laziness pass, because it may
472         -- succeed in commoning up things floated out by full laziness.
473         --
474         -- CSE must immediately follow a simplification pass, because it relies
475         -- on the no-shadowing invariant.  See comments at the top of CSE.lhs
476         -- So it must NOT follow float-inwards, which can give rise to shadowing,
477         -- even if its input doesn't have shadows.  Hence putting it between
478         -- the two passes.
479         "-fcse",        
480                         
481
482         "-ffloat-inwards",
483
484 -- Case-liberation for -O2.  This should be after
485 -- strictness analysis and the simplification which follows it.
486
487 --        ( ($OptLevel != 2)
488 --        ? ""
489 --        : "-fliberate-case -fsimplify [ $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MaxSimplifierIterations $Oopt_ShowSimplifierProgress ]" ),
490 --
491 --        "-fliberate-case",
492
493         -- Final clean-up simplification:
494         "-fsimplify",
495           "[", 
496                 "-fmax-simplifier-iterations" ++ show iter,
497                 -- No -finline-phase: allow all Ids to be inlined now
498           "]"
499
500         ]
501
502 -----------------------------------------------------------------------------
503 -- Paths & Libraries
504
505 split_marker = ':'   -- not configurable
506
507 import_paths, include_paths, library_paths :: IORef [String]
508 GLOBAL_VAR(import_paths,  ["."], [String])
509 GLOBAL_VAR(include_paths, ["."], [String])
510 GLOBAL_VAR(library_paths, [],    [String])
511
512 GLOBAL_VAR(cmdline_libraries,   [], [String])
513 GLOBAL_VAR(cmdline_hc_includes, [], [String])
514
515 augment_import_paths :: String -> IO ()
516 augment_import_paths "" = writeIORef import_paths []
517 augment_import_paths path
518   = do paths <- readIORef import_paths
519        writeIORef import_paths (paths ++ dirs)
520   where dirs = split split_marker path
521
522 augment_include_paths :: String -> IO ()
523 augment_include_paths path
524   = do paths <- readIORef include_paths
525        writeIORef include_paths (paths ++ split split_marker path)
526
527 augment_library_paths :: String -> IO ()
528 augment_library_paths path
529   = do paths <- readIORef library_paths
530        writeIORef library_paths (paths ++ split split_marker path)
531
532 -----------------------------------------------------------------------------
533 -- Packages
534
535 -- package list is maintained in dependency order
536 packages = global ["std", "rts", "gmp"] :: IORef [String]
537 -- comma in value, so can't use macro, grrr
538 {-# NOINLINE packages #-}
539
540 addPackage :: String -> IO ()
541 addPackage package
542   = do pkg_details <- readIORef package_details
543        case lookup package pkg_details of
544           Nothing -> throwDyn (UnknownPackage package)
545           Just details -> do
546             ps <- readIORef packages
547             if package `elem` ps 
548                 then return ()
549                 else do mapM_ addPackage (package_deps details)
550                         ps <- readIORef packages
551                         writeIORef packages (package:ps)
552
553 getPackageImportPath   :: IO [String]
554 getPackageImportPath = do
555   ps <- readIORef packages
556   ps' <- getPackageDetails ps
557   return (nub (concat (map import_dirs ps')))
558
559 getPackageIncludePath   :: IO [String]
560 getPackageIncludePath = do
561   ps <- readIORef packages
562   ps' <- getPackageDetails ps
563   return (nub (filter (not.null) (map include_dir ps')))
564
565         -- includes are in reverse dependency order (i.e. rts first)
566 getPackageCIncludes   :: IO [String]
567 getPackageCIncludes = do
568   ps <- readIORef packages
569   ps' <- getPackageDetails ps
570   return (reverse (nub (filter (not.null) (map c_include ps'))))
571
572 getPackageLibraryPath  :: IO [String]
573 getPackageLibraryPath = do
574   ps <- readIORef packages
575   ps' <- getPackageDetails ps
576   return (nub (concat (map library_dirs ps')))
577
578 getPackageLibraries    :: IO [String]
579 getPackageLibraries = do
580   ps <- readIORef packages
581   ps' <- getPackageDetails ps
582   tag <- readIORef build_tag
583   let suffix = if null tag then "" else '_':tag
584   return (concat (map libraries ps'))
585
586 getPackageExtraGhcOpts :: IO [String]
587 getPackageExtraGhcOpts = do
588   ps <- readIORef packages
589   ps' <- getPackageDetails ps
590   return (map extra_ghc_opts ps')
591
592 getPackageExtraCcOpts  :: IO [String]
593 getPackageExtraCcOpts = do
594   ps <- readIORef packages
595   ps' <- getPackageDetails ps
596   return (map extra_cc_opts ps')
597
598 getPackageExtraLdOpts  :: IO [String]
599 getPackageExtraLdOpts = do
600   ps <- readIORef packages
601   ps' <- getPackageDetails ps
602   return (map extra_ld_opts ps')
603
604 getPackageDetails ps = do
605   pkg_details <- readIORef package_details
606   let getDetails p =  case lookup p pkg_details of
607                         Just details -> return details
608                         Nothing -> error "getPackageDetails"
609   mapM getDetails ps
610
611 GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
612
613 -----------------------------------------------------------------------------
614 -- Ways
615
616 -- The central concept of a "way" is that all objects in a given
617 -- program must be compiled in the same "way".  Certain options change
618 -- parameters of the virtual machine, eg. profiling adds an extra word
619 -- to the object header, so profiling objects cannot be linked with
620 -- non-profiling objects.
621
622 -- After parsing the command-line options, we determine which "way" we
623 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
624
625 -- We then find the "build-tag" associated with this way, and this
626 -- becomes the suffix used to find .hi files and libraries used in
627 -- this compilation.
628
629 GLOBAL_VAR(build_tag, "", String)
630
631 data WayName
632   = WayProf
633   | WayUnreg
634   | WayTicky
635   | WayPar
636   | WayGran
637   | WaySMP
638   | WayDebug
639   | WayUser_a
640   | WayUser_b
641   | WayUser_c
642   | WayUser_d
643   | WayUser_e
644   | WayUser_f
645   | WayUser_g
646   | WayUser_h
647   | WayUser_i
648   | WayUser_j
649   | WayUser_k
650   | WayUser_l
651   | WayUser_m
652   | WayUser_n
653   | WayUser_o
654   | WayUser_A
655   | WayUser_B
656   deriving (Eq,Ord)
657
658 GLOBAL_VAR(ways, [] ,[WayName])
659
660 allowed_combinations = 
661    [  [WayProf,WayUnreg],
662       [WayProf,WaySMP]     -- works???
663    ]
664
665 findBuildTag :: IO [String]  -- new options
666 findBuildTag = do
667   way_names <- readIORef ways
668   case sort way_names of
669      []  -> do  writeIORef build_tag ""
670                 return []
671
672      [w] -> do let details = lkupWay w
673                writeIORef build_tag (wayTag details)
674                return (wayOpts details)
675
676      ws  -> if  ws `notElem` allowed_combinations
677                 then throwDyn (WayCombinationNotSupported ws)
678                 else let stuff = map lkupWay ws
679                          tag   = concat (map wayTag stuff)
680                          flags = map wayOpts stuff
681                      in do
682                      writeIORef build_tag tag
683                      return (concat flags)
684
685 lkupWay w = 
686    case lookup w way_details of
687         Nothing -> error "findBuildTag"
688         Just details -> details
689
690 data Way = Way {
691   wayTag   :: String,
692   wayName  :: String,
693   wayOpts  :: [String]
694   }
695
696 way_details :: [ (WayName, Way) ]
697 way_details =
698   [ (WayProf, Way  "p" "Profiling"  
699         [ "-fscc-profiling"
700         , "-DPROFILING"
701         , "-optc-DPROFILING" ]),
702
703     (WayTicky, Way  "t" "Ticky-ticky Profiling"  
704         [ "-fticky-ticky"
705         , "-DTICKY_TICKY"
706         , "-optc-DTICKY_TICKY" ]),
707
708     (WayUnreg, Way  "u" "Unregisterised" 
709         [ "-optc-DNO_REGS"
710         , "-optc-DUSE_MINIINTERPRETER"
711         , "-fno-asm-mangling"
712         , "-funregisterised" ]),
713
714     (WayPar, Way  "mp" "Parallel" 
715         [ "-fstack-check"
716         , "-fparallel"
717         , "-D__PARALLEL_HASKELL__"
718         , "-optc-DPAR"
719         , "-package concurrent" ]),
720
721     (WayGran, Way  "mg" "Gransim" 
722         [ "-fstack-check"
723         , "-fgransim"
724         , "-D__GRANSIM__"
725         , "-optc-DGRAN"
726         , "-package concurrent" ]),
727
728     (WaySMP, Way  "s" "SMP"  
729         [ "-fsmp"
730         , "-optc-pthread"
731         , "-optl-pthread"
732         , "-optc-DSMP" ]),
733
734     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),       
735     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),       
736     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),       
737     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),       
738     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),       
739     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),       
740     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),       
741     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),       
742     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),       
743     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),       
744     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),       
745     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),       
746     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),       
747     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),       
748     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),       
749     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),       
750     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"]) 
751   ]
752
753 -----------------------------------------------------------------------------
754 -- Programs for particular phases
755
756 GLOBAL_VAR(pgm_dep, findFile "mkdependHS" cGHC_MKDEPENDHS, String)
757 GLOBAL_VAR(pgm_L,   findFile "unlit"      cGHC_UNLIT,      String)
758 GLOBAL_VAR(pgm_P,   cRAWCPP,                               String)
759 GLOBAL_VAR(pgm_C,   findFile "hsc"        cGHC_HSC,        String)
760 GLOBAL_VAR(pgm_c,   cGCC,                                  String)
761 GLOBAL_VAR(pgm_m,   findFile "ghc-asm"    cGHC_MANGLER,    String)
762 GLOBAL_VAR(pgm_s,   findFile "ghc-split"  cGHC_SPLIT,      String)
763 GLOBAL_VAR(pgm_a,   cGCC,                                  String)
764 GLOBAL_VAR(pgm_l,   cGCC,                                  String)
765
766 -----------------------------------------------------------------------------
767 -- Options for particular phases
768
769 GLOBAL_VAR(opt_dep, [], [String])
770 GLOBAL_VAR(opt_L, [], [String])
771 GLOBAL_VAR(opt_P, [], [String])
772 GLOBAL_VAR(opt_C, [], [String])
773 GLOBAL_VAR(opt_Crts, [], [String])
774 GLOBAL_VAR(opt_c, [], [String])
775 GLOBAL_VAR(opt_a, [], [String])
776 GLOBAL_VAR(opt_m, [], [String])
777 GLOBAL_VAR(opt_l, [], [String])
778 GLOBAL_VAR(opt_dll, [], [String])
779
780         -- we add to the options from the front, so we need to reverse the list
781 getOpts :: IORef [String] -> IO [String]
782 getOpts opts = readIORef opts >>= return . reverse
783
784 GLOBAL_VAR(anti_opt_C, [], [String])
785
786 -----------------------------------------------------------------------------
787 -- Via-C compilation stuff
788
789 -- flags returned are: ( all C compilations
790 --                     , registerised HC compilations
791 --                     )
792
793 machdepCCOpts 
794    | prefixMatch "alpha"   cTARGETPLATFORM  
795         = return ( ["-static"], [] )
796
797    | prefixMatch "hppa"    cTARGETPLATFORM  
798         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
799         -- (very nice, but too bad the HP /usr/include files don't agree.)
800         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
801
802    | prefixMatch "m68k"    cTARGETPLATFORM
803       -- -fno-defer-pop : for the .hc files, we want all the pushing/
804       --    popping of args to routines to be explicit; if we let things
805       --    be deferred 'til after an STGJUMP, imminent death is certain!
806       --
807       -- -fomit-frame-pointer : *don't*
808       --     It's better to have a6 completely tied up being a frame pointer
809       --     rather than let GCC pick random things to do with it.
810       --     (If we want to steal a6, then we would try to do things
811       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
812         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
813
814    | prefixMatch "i386"    cTARGETPLATFORM  
815       -- -fno-defer-pop : basically the same game as for m68k
816       --
817       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
818       --   the fp (%ebp) for our register maps.
819         = do n_regs <- readIORef stolen_x86_regs
820              sta    <- readIORef static
821              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
822                       [ "-fno-defer-pop", "-fomit-frame-pointer",
823                         "-DSTOLEN_X86_REGS="++show n_regs ]
824                     )
825
826    | prefixMatch "mips"    cTARGETPLATFORM
827         = return ( ["static"], [] )
828
829    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
830         = return ( ["static"], ["-finhibit-size-directive"] )
831
832    | otherwise
833         = return ( [], [] )
834
835 -----------------------------------------------------------------------------
836 -- Build the Hsc command line
837
838 build_hsc_opts :: IO [String]
839 build_hsc_opts = do
840   opt_C_ <- getOpts opt_C               -- misc hsc opts
841
842         -- warnings
843   warn_level <- readIORef warning_opt
844   let warn_opts =  case warn_level of
845                         W_default -> standardWarnings
846                         W_        -> minusWOpts
847                         W_all     -> minusWallOpts
848                         W_not     -> []
849
850         -- optimisation
851   minus_o <- readIORef opt_level
852   optimisation_opts <-
853         case minus_o of
854             0 -> hsc_minusNoO_flags
855             1 -> hsc_minusO_flags
856             2 -> hsc_minusO2_flags
857             -- ToDo: -Ofile
858  
859         -- STG passes
860   ways_ <- readIORef ways
861   let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
862                   | otherwise            = ""
863
864   stg_stats <- readIORef opt_StgStats
865   let stg_stats_flag | stg_stats = "-dstg-stats"
866                      | otherwise = ""
867
868   let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
869         -- let-no-escape always on for now
870
871   verb <- is_verbose
872   let hi_vers = "-fhi-version="++cProjectVersionInt
873   static <- (do s <- readIORef static; if s then return "-static" else return "")
874
875   l <- readIORef hsc_lang
876   let lang = case l of
877                 HscC    -> "-olang=C"
878                 HscAsm  -> "-olang=asm"
879                 HscJava -> "-olang=java"
880
881   -- get hi-file suffix
882   hisuf <- readIORef hi_suf
883
884   -- hi-suffix for packages depends on the build tag.
885   package_hisuf <-
886         do tag <- readIORef build_tag
887            if null tag
888                 then return "hi"
889                 else return (tag ++ "_hi")
890
891   import_dirs <- readIORef import_paths
892   package_import_dirs <- getPackageImportPath
893   
894   let hi_map = "-himap=" ++
895                 makeHiMap import_dirs hisuf 
896                          package_import_dirs package_hisuf
897                          split_marker
898
899       hi_map_sep = "-himap-sep=" ++ [split_marker]
900
901   scale <- readIORef scale_sizes_by
902   heap  <- readIORef specific_heap_size
903   stack <- readIORef specific_stack_size
904   cmdline_rts_opts <- getOpts opt_Crts
905   let heap'  = truncate (fromIntegral heap  * scale) :: Integer
906       stack' = truncate (fromIntegral stack * scale) :: Integer
907       rts_opts = [ "+RTS", "-H"++show heap', "-K"++show stack' ]
908                  ++ cmdline_rts_opts ++ [ "-RTS" ]
909
910   -- take into account -fno-* flags by removing the equivalent -f*
911   -- flag from our list.
912   anti_flags <- getOpts anti_opt_C
913   let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
914       filtered_opts = filter (`notElem` anti_flags) basic_opts
915   
916   return 
917         (  
918         filtered_opts
919         -- ToDo: C stub files
920         ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
921         ++ rts_opts
922         )
923
924 makeHiMap 
925   (import_dirs         :: [String])
926   (hi_suffix           :: String)
927   (package_import_dirs :: [String])
928   (package_hi_suffix   :: String)   
929   (split_marker        :: Char)
930   = foldr (add_dir hi_suffix) 
931         (foldr (add_dir package_hi_suffix) "" package_import_dirs)
932         import_dirs
933   where
934      add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
935
936
937 getOptionsFromSource 
938         :: String               -- input file
939         -> IO [String]          -- options, if any
940 getOptionsFromSource file
941   = do h <- openFile file ReadMode
942        look h
943   where
944         look h = do
945             l <- hGetLine h
946             case () of
947                 () | null l -> look h
948                    | prefixMatch "#" l -> look h
949                    | prefixMatch "{-# LINE" l -> look h
950                    | Just (opts:_) <- matchRegex optionRegex l
951                         -> return (words opts)
952                    | otherwise -> return []
953
954 optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}"
955
956 -----------------------------------------------------------------------------
957 -- Main loop
958
959 get_source_files :: [String] -> ([String],[String])
960 get_source_files = partition (('-' /=) . head)
961
962 suffixes :: [(String,Phase)]
963 suffixes =
964   [ ("lhs",   Unlit)
965   , ("hs",    Cpp)
966   , ("hc",    HCc)
967   , ("c",     Cc)
968   , ("raw_s", Mangle)
969   , ("s",     As)
970   , ("S",     As)
971   , ("o",     Ln)
972   ]
973
974 phase_input_ext Unlit       = "lhs"
975 phase_input_ext Cpp         = "lpp"
976 phase_input_ext Hsc         = "cpp"
977 phase_input_ext HCc         = "hc"
978 phase_input_ext Cc          = "c"
979 phase_input_ext Mangle      = "raw_s"
980 phase_input_ext SplitMangle = "split_s" -- not really generated
981 phase_input_ext As          = "s"
982 phase_input_ext SplitAs     = "split_s" -- not really generated
983 phase_input_ext Ln          = "o"
984
985 find_phase :: String -> ([(Phase,String)], [String])
986    -> ([(Phase,String)], [String])
987 find_phase f (phase_srcs, unknown_srcs)
988   = case lookup ext suffixes of
989         Just the_phase -> ((the_phase,f):phase_srcs, unknown_srcs)
990         Nothing        -> (phase_srcs, f:unknown_srcs)
991   where (basename,ext) = split_filename f
992
993
994 find_phases srcs = (phase_srcs, unknown_srcs)
995   where (phase_srcs, unknown_srcs) = foldr find_phase ([],[]) srcs
996
997 main =
998   -- all error messages are propagated as exceptions
999   my_catchDyn (\dyn -> case dyn of
1000                           PhaseFailed phase code -> exitWith code
1001                           Interrupted -> exitWith (ExitFailure 1)
1002                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
1003                                   exitWith (ExitFailure 1)) $
1004
1005   later cleanTempFiles $
1006         -- exceptions will be blocked while we clean the temporary files,
1007         -- so there shouldn't be any difficulty if we receive further
1008         -- signals.
1009
1010   do
1011         -- install signal handlers
1012    main_thread <- myThreadId
1013    let sig_handler = Catch (raiseInThread main_thread 
1014                                 (DynException (toDyn Interrupted)))
1015    installHandler sigQUIT sig_handler Nothing 
1016    installHandler sigINT  sig_handler Nothing
1017
1018    pgm    <- getProgName
1019    writeIORef prog_name pgm
1020
1021    argv   <- getArgs
1022
1023    -- grab any -B options from the command line first
1024    argv'  <- setTopDir argv
1025
1026    -- read the package configuration
1027    let conf = findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")
1028    contents <- readFile conf
1029    writeIORef package_details (read contents)
1030
1031    -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
1032    (flags2, stop_phase, do_linking) <- getStopAfter argv'
1033
1034    -- process all the other arguments, and get the source files
1035    srcs   <- processArgs flags2 []
1036
1037    -- find the build tag, and re-process the build-specific options
1038    more_opts <- findBuildTag
1039    _ <- processArgs more_opts []
1040
1041    if stop_phase == MkDependHS          -- mkdependHS is special
1042         then do_mkdependHS flags2 srcs
1043         else do
1044
1045    -- for each source file, find which phase to start at
1046    let (phase_srcs, unknown_srcs) = find_phases srcs
1047
1048    o_file <- readIORef output_file
1049    if isJust o_file && not do_linking && length phase_srcs > 1
1050         then throwDyn MultipleSrcsOneOutput
1051         else do
1052
1053    if null unknown_srcs && null phase_srcs
1054         then throwDyn NoInputFiles
1055         else do
1056
1057    -- if we have unknown files, and we're not doing linking, complain
1058    -- (otherwise pass them through to the linker).
1059    if not (null unknown_srcs) && not do_linking
1060         then throwDyn (UnknownFileType (head unknown_srcs))
1061         else do
1062
1063    let  compileFile :: (Phase, String) -> IO String
1064         compileFile (phase, src) = do
1065           let (orig_base, _) = split_filename src
1066           if phase < Ln -- anything to do?
1067                 then run_pipeline stop_phase do_linking True orig_base (phase,src)
1068                 else return src
1069
1070    o_files <- mapM compileFile phase_srcs
1071
1072    if do_linking
1073         then do_link o_files unknown_srcs
1074         else return ()
1075
1076
1077 -- The following compilation pipeline algorithm is fairly hacky.  A
1078 -- better way to do this would be to express the whole comilation as a
1079 -- data flow DAG, where the nodes are the intermediate files and the
1080 -- edges are the compilation phases.  This framework would also work
1081 -- nicely if a haskell dependency generator was included in the
1082 -- driver.
1083
1084 -- It would also deal much more cleanly with compilation phases that
1085 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
1086 -- possibly stub files), where some of the output files need to be
1087 -- processed further (eg. the stub files need to be compiled by the C
1088 -- compiler).
1089
1090 -- A cool thing to do would then be to execute the data flow graph
1091 -- concurrently, automatically taking advantage of extra processors on
1092 -- the host machine.  For example, when compiling two Haskell files
1093 -- where one depends on the other, the data flow graph would determine
1094 -- that the C compiler from the first comilation can be overlapped
1095 -- with the hsc comilation for the second file.
1096
1097 run_pipeline
1098   :: Phase              -- phase to end on (never Linker)
1099   -> Bool               -- doing linking afterward?
1100   -> Bool               -- take into account -o when generating output?
1101   -> String             -- original basename (eg. Main)
1102   -> (Phase, String)    -- phase to run, input file
1103   -> IO String          -- return final filename
1104
1105 run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn) 
1106   | phase > last_phase = return input_fn
1107   | otherwise
1108   = do
1109
1110      let (basename,ext) = split_filename input_fn
1111
1112      split  <- readIORef split_object_files
1113      mangle <- readIORef do_asm_mangling
1114      lang   <- readIORef hsc_lang
1115
1116         -- figure out what the next phase is.  This is
1117         -- straightforward, apart from the fact that hsc can generate
1118         -- either C or assembler direct, and assembly mangling is
1119         -- optional, and splitting involves one extra phase and an alternate
1120         -- assembler.
1121      let next_phase =
1122           case phase of
1123                 Hsc -> case lang of
1124                             HscC   -> HCc
1125                             HscAsm -> As
1126
1127                 HCc  | mangle    -> Mangle
1128                      | otherwise -> As
1129
1130                 Cc -> As
1131
1132                 Mangle | not split -> As
1133                 SplitMangle -> SplitAs
1134                 SplitAs -> Ln
1135
1136                 _  -> succ phase
1137
1138
1139         -- filename extension for the output, determined by next_phase
1140      let new_ext = phase_input_ext next_phase
1141
1142         -- Figure out what the output from this pass should be called.
1143
1144         -- If we're keeping the output from this phase, then we just save
1145         -- it in the current directory, otherwise we generate a new temp file.
1146      keep_s <- readIORef keep_s_files
1147      keep_raw_s <- readIORef keep_raw_s_files
1148      keep_hc <- readIORef keep_hc_files
1149      let keep_this_output = 
1150            case next_phase of
1151                 Ln -> True
1152                 Mangle | keep_raw_s -> True -- first enhancement :)
1153                 As | keep_s  -> True
1154                 Cc | keep_hc -> True
1155                 _other -> False
1156
1157      output_fn <- 
1158         (if phase == last_phase && not do_linking && use_ofile
1159             then do o_file <- readIORef output_file
1160                     case o_file of 
1161                         Just s  -> return s
1162                         Nothing -> do
1163                             f <- odir_ify (orig_basename ++ '.':new_ext)
1164                             osuf_ify f
1165
1166                 -- .o files are always kept.  .s files and .hc file may be kept.
1167             else if keep_this_output
1168                         then odir_ify (orig_basename ++ '.':new_ext)
1169                         else do filename <- newTempName new_ext
1170                                 add files_to_clean filename
1171                                 return filename
1172         )
1173
1174      run_phase phase orig_basename input_fn output_fn
1175
1176         -- sadly, ghc -E is supposed to write the file to stdout.  We
1177         -- generate <file>.cpp, so we also have to cat the file here.
1178      if (next_phase > last_phase && last_phase == Cpp)
1179         then run_something "Dump pre-processed file to stdout"
1180                 ("cat " ++ output_fn)
1181         else return ()
1182
1183      run_pipeline last_phase do_linking use_ofile 
1184           orig_basename (next_phase, output_fn)
1185
1186
1187 -- find a temporary name that doesn't already exist.
1188 newTempName :: String -> IO String
1189 newTempName extn = do
1190   x <- getProcessID
1191   tmp_dir <- readIORef tmp_prefix 
1192   findTempName tmp_dir x
1193   where findTempName tmp_dir x = do
1194            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
1195            b  <- fileExist filename
1196            if b then findTempName tmp_dir (x+1)
1197                 else return filename
1198
1199 -------------------------------------------------------------------------------
1200 -- mkdependHS phase 
1201
1202 do_mkdependHS :: [String] -> [String] -> IO ()
1203 do_mkdependHS cmd_opts srcs = do
1204
1205     --  # They're not (currently) needed, but we need to quote any -#include options
1206     -- foreach (@Cmd_opts) {
1207     --     s/-#include.*$/'$&'/g;
1208     -- };  
1209
1210    mkdependHS      <- readIORef pgm_dep
1211    mkdependHS_opts <- getOpts opt_dep
1212    hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1213
1214    run_something "Dependency generation"
1215         (unwords (mkdependHS : 
1216                       mkdependHS_opts
1217                    ++ hs_src_cpp_opts
1218                    ++ ("--" : cmd_opts )
1219                    ++ ("--" : srcs)
1220         ))
1221
1222 -------------------------------------------------------------------------------
1223 -- Unlit phase 
1224
1225 run_phase Unlit basename input_fn output_fn
1226   = do unlit <- readIORef pgm_L
1227        unlit_flags <- getOpts opt_L
1228        run_something "Literate pre-processor"
1229           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
1230            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
1231
1232 -------------------------------------------------------------------------------
1233 -- Cpp phase 
1234
1235 run_phase Cpp basename input_fn output_fn
1236   = do src_opts <- getOptionsFromSource input_fn
1237        processArgs src_opts []
1238
1239        do_cpp <- readIORef cpp_flag
1240        if do_cpp
1241           then do
1242             cpp <- readIORef pgm_P
1243             hscpp_opts <- getOpts opt_P
1244             hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1245
1246             cmdline_include_paths <- readIORef include_paths
1247             pkg_include_dirs <- getPackageIncludePath
1248             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
1249                                                         ++ pkg_include_dirs)
1250
1251             verb <- is_verbose
1252             run_something "C pre-processor" 
1253                 (unwords
1254                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
1255                      cpp, verb] 
1256                     ++ include_paths
1257                     ++ hs_src_cpp_opts
1258                     ++ hscpp_opts
1259                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
1260                    ))
1261           else do
1262             run_something "Inefective C pre-processor"
1263                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > " 
1264                     ++ output_fn ++ " && cat " ++ input_fn
1265                     ++ " >> " ++ output_fn)
1266
1267 -----------------------------------------------------------------------------
1268 -- Hsc phase
1269
1270 run_phase Hsc   basename input_fn output_fn
1271   = do  hsc <- readIORef pgm_C
1272         
1273   -- we add the current directory (i.e. the directory in which
1274   -- the .hs files resides) to the import path, since this is
1275   -- what gcc does, and it's probably what you want.
1276         let current_dir = getdir basename
1277         
1278         paths <- readIORef include_paths
1279         writeIORef include_paths (current_dir : paths)
1280         
1281   -- build the hsc command line
1282         hsc_opts <- build_hsc_opts
1283         
1284         doing_hi <- readIORef produceHi
1285         tmp_hi_file <- if doing_hi      
1286                           then do fn <- newTempName "hi"
1287                                   add files_to_clean fn
1288                                   return fn
1289                           else return ""
1290         
1291         let hi_flag = if doing_hi then "-hifile=" ++ tmp_hi_file
1292                                   else ""
1293         
1294   -- deal with -Rghc-timing
1295         timing <- readIORef collect_ghc_timing
1296         stat_file <- newTempName "stat"
1297         add files_to_clean stat_file
1298         let stat_opts | timing    = [ "+RTS", "-S"++stat_file, "-RTS" ]
1299                       | otherwise = []
1300
1301   -- tmp files for foreign export stub code
1302         tmp_stub_h <- newTempName "stub_h"
1303         tmp_stub_c <- newTempName "stub_c"
1304         add files_to_clean tmp_stub_h
1305         add files_to_clean tmp_stub_c
1306         
1307   -- figure out where to put the .hi file
1308         ohi    <- readIORef output_hi
1309         hisuf  <- readIORef hi_suf
1310         let hi_flags = case ohi of
1311                            Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
1312                            Just fn -> [ "-hifile="++fn ]
1313
1314   -- run the compiler!
1315         run_something "Haskell Compiler" 
1316                  (unwords (hsc : input_fn : (
1317                     hsc_opts
1318                     ++ hi_flags
1319                     ++ [ 
1320                           "-ofile="++output_fn, 
1321                           "-F="++tmp_stub_c, 
1322                           "-FH="++tmp_stub_h 
1323                        ]
1324                     ++ stat_opts
1325                  )))
1326
1327   -- Generate -Rghc-timing info
1328         on (timing) (
1329             run_something "Generate timing stats"
1330                 (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
1331          )
1332
1333   -- Deal with stubs
1334         let stub_h = basename ++ "_stub.h"
1335         let stub_c = basename ++ "_stub.c"
1336         
1337                 -- copy .h_stub file into current dir if present
1338         b <- fileExist tmp_stub_h
1339         on b (do
1340                 run_something "Copy stub .h file"
1341                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
1342         
1343                         -- #include <..._stub.h> in .hc file
1344                 add cmdline_hc_includes tmp_stub_h      -- hack
1345
1346                         -- copy the _stub.c file into the current dir
1347                 run_something "Copy stub .c file" 
1348                     (unwords [ 
1349                         "rm -f", stub_c, "&&",
1350                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
1351                         "cat", tmp_stub_c, ">> ", stub_c
1352                         ])
1353
1354                         -- compile the _stub.c file w/ gcc
1355                 run_pipeline As False{-no linking-} 
1356                                 False{-no -o option-}
1357                                 (basename++"_stub")
1358                                 (Cc, stub_c)
1359
1360                 add ld_inputs (basename++"_stub.o")
1361          )
1362
1363 -----------------------------------------------------------------------------
1364 -- Cc phase
1365
1366 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
1367 -- way too many hacks, and I can't say I've ever used it anyway.
1368
1369 run_phase cc_phase basename input_fn output_fn
1370    | cc_phase == Cc || cc_phase == HCc
1371    = do cc <- readIORef pgm_c
1372         cc_opts <- getOpts opt_c
1373         cmdline_include_dirs <- readIORef include_paths
1374        -- ToDo: $c_flags .= " -mno-cygwin" if ( $TargetPlatform =~ /-mingw32$/ );
1375
1376         let hcc = cc_phase == HCc
1377
1378                 -- add package include paths even if we're just compiling
1379                 -- .c files; this is the Value Add(TM) that using
1380                 -- ghc instead of gcc gives you :)
1381         pkg_include_dirs <- getPackageIncludePath
1382         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs 
1383                                                         ++ pkg_include_dirs)
1384
1385         c_includes <- getPackageCIncludes
1386         cmdline_includes <- readIORef cmdline_hc_includes -- -#include options
1387
1388         let cc_injects | hcc = unlines (map mk_include 
1389                                         (c_includes ++ reverse cmdline_includes))
1390                        | otherwise = ""
1391             mk_include h_file = 
1392                 case h_file of 
1393                    '"':_{-"-} -> "#include "++h_file
1394                    '<':_      -> "#include "++h_file
1395                    _          -> "#include \""++h_file++"\""
1396
1397         cc_help <- newTempName "c"
1398         add files_to_clean cc_help
1399         h <- openFile cc_help WriteMode
1400         hPutStr h cc_injects
1401         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
1402         hClose h
1403
1404         ccout <- newTempName "ccout"
1405         add files_to_clean ccout
1406
1407         mangle <- readIORef do_asm_mangling
1408         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
1409
1410         verb <- is_verbose
1411
1412         o2 <- readIORef opt_minus_o2_for_C
1413         let opt_flag | o2        = "-O2"
1414                      | otherwise = "-O"
1415
1416         pkg_extra_cc_opts <- getPackageExtraCcOpts
1417
1418         run_something "C Compiler"
1419          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
1420                    ++ md_c_flags
1421                    ++ (if cc_phase == HCc && mangle
1422                          then md_regd_c_flags
1423                          else [])
1424                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
1425                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1426                    ++ cc_opts
1427                    ++ include_paths
1428                    ++ pkg_extra_cc_opts
1429 --                 ++ [">", ccout]
1430                    ))
1431
1432         -- ToDo: postprocess the output from gcc
1433
1434 -----------------------------------------------------------------------------
1435 -- Mangle phase
1436
1437 run_phase Mangle basename input_fn output_fn
1438   = do mangler <- readIORef pgm_m
1439        mangler_opts <- getOpts opt_m
1440        machdep_opts <-
1441          if (prefixMatch "i386" cTARGETPLATFORM)
1442             then do n_regs <- readIORef stolen_x86_regs
1443                     return [ show n_regs ]
1444             else return []
1445        run_something "Assembly Mangler"
1446         (unwords (mangler : 
1447                      mangler_opts
1448                   ++ [ input_fn, output_fn ]
1449                   ++ machdep_opts
1450                 ))
1451
1452 -----------------------------------------------------------------------------
1453 -- Splitting phase
1454
1455 run_phase SplitMangle basename input_fn outputfn
1456   = do  splitter <- readIORef pgm_s
1457
1458         -- this is the prefix used for the split .s files
1459         tmp_pfx <- readIORef tmp_prefix
1460         x <- getProcessID
1461         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1462         writeIORef split_prefix split_s_prefix
1463         add files_to_clean (split_s_prefix ++ "__*") -- d:-)
1464
1465         -- allocate a tmp file to put the no. of split .s files in (sigh)
1466         n_files <- newTempName "n_files"
1467         add files_to_clean n_files
1468
1469         run_something "Split Assembly File"
1470          (unwords [ splitter
1471                   , input_fn
1472                   , split_s_prefix
1473                   , n_files ]
1474          )
1475
1476         -- save the number of split files for future references
1477         s <- readFile n_files
1478         let n = read s :: Int
1479         writeIORef n_split_files n
1480
1481 -----------------------------------------------------------------------------
1482 -- As phase
1483
1484 run_phase As basename input_fn output_fn
1485   = do  as <- readIORef pgm_a
1486         as_opts <- getOpts opt_a
1487
1488         cmdline_include_paths <- readIORef include_paths
1489         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1490         run_something "Assembler"
1491            (unwords (as : as_opts
1492                        ++ cmdline_include_flags
1493                        ++ [ "-c", input_fn, "-o",  output_fn ]
1494                     ))
1495
1496 run_phase SplitAs basename input_fn output_fn
1497   = do  as <- readIORef pgm_a
1498         as_opts <- getOpts opt_a
1499
1500         odir_opt <- readIORef output_dir
1501         let odir | Just s <- odir_opt = s
1502                      | otherwise          = basename
1503         
1504         split_s_prefix <- readIORef split_prefix
1505         n <- readIORef n_split_files
1506
1507         odir <- readIORef output_dir
1508         let real_odir = case odir of
1509                                 Nothing -> basename
1510                                 Just d  -> d
1511
1512         let assemble_file n = do
1513                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
1514                     let output_o = newdir real_odir 
1515                                         (basename ++ "__" ++ show n ++ ".o")
1516                     real_o <- osuf_ify output_o
1517                     run_something "Assembler" 
1518                             (unwords (as : as_opts
1519                                       ++ [ "-c", "-o", real_o, input_s ]
1520                             ))
1521         
1522         mapM_ assemble_file [1..n]
1523
1524 -----------------------------------------------------------------------------
1525 -- Linking
1526
1527 do_link :: [String] -> [String] -> IO ()
1528 do_link o_files unknown_srcs = do
1529     ln <- readIORef pgm_l
1530     verb <- is_verbose
1531     o_file <- readIORef output_file
1532     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1533
1534     pkg_lib_paths <- getPackageLibraryPath
1535     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1536
1537     lib_paths <- readIORef library_paths
1538     let lib_path_opts = map ("-L"++) lib_paths
1539
1540     pkg_libs <- getPackageLibraries
1541     let pkg_lib_opts = map ("-l"++) pkg_libs
1542
1543     libs <- readIORef cmdline_libraries
1544     let lib_opts = map ("-l"++) (reverse libs)
1545          -- reverse because they're added in reverse order from the cmd line
1546
1547     pkg_extra_ld_opts <- getPackageExtraLdOpts
1548
1549         -- probably _stub.o files
1550     extra_ld_inputs <- readIORef ld_inputs
1551
1552         -- opts from -optl-<blah>
1553     extra_ld_opts <- getOpts opt_l
1554
1555     run_something "Linker"
1556        (unwords 
1557          ([ ln, verb, "-o", output_fn ]
1558          ++ o_files
1559          ++ unknown_srcs
1560          ++ extra_ld_inputs
1561          ++ lib_path_opts
1562          ++ lib_opts
1563          ++ pkg_lib_path_opts
1564          ++ pkg_lib_opts
1565          ++ pkg_extra_ld_opts
1566          ++ extra_ld_opts
1567         )
1568        )
1569
1570 -----------------------------------------------------------------------------
1571 -- Running an external program
1572
1573 run_something phase_name cmd
1574  = do
1575    verb <- readIORef verbose
1576    if verb then do
1577         putStr phase_name
1578         putStrLn ":"
1579         putStrLn cmd
1580      else
1581         return ()
1582
1583    -- test for -n flag
1584    n <- readIORef dry_run
1585    if n then return () else do 
1586
1587    -- and run it!
1588    exit_code <- system cmd  `catchAllIO` 
1589                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
1590
1591    if exit_code /= ExitSuccess
1592         then throwDyn (PhaseFailed phase_name exit_code)
1593         else do on verb (putStr "\n")
1594                 return ()
1595
1596 -----------------------------------------------------------------------------
1597 -- Flags
1598
1599 data OptKind 
1600         = NoArg (IO ())                 -- flag with no argument
1601         | HasArg (String -> IO ())      -- flag has an argument (maybe prefix)
1602         | SepArg (String -> IO ())      -- flag has a separate argument
1603         | Prefix (String -> IO ())      -- flag is a prefix only
1604         | OptPrefix (String -> IO ())   -- flag may be a prefix
1605         | AnySuffix (String -> IO ())   -- flag is a prefix, pass whole arg to fn
1606         | PassFlag  (String -> IO ())   -- flag with no arg, pass flag to fn
1607
1608 -- note that ordering is important in the following list: any flag which
1609 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
1610 -- flags further down the list with the same prefix.
1611
1612 opts = 
1613   [  ------- help -------------------------------------------------------
1614      ( "?"              , NoArg long_usage)
1615   ,  ( "-help"          , NoArg long_usage)
1616   
1617
1618       ------- version ----------------------------------------------------
1619   ,  ( "-version"        , NoArg (do hPutStrLn stderr (cProjectName
1620                                       ++ ", version " ++ version_str)
1621                                      exitWith ExitSuccess))
1622   ,  ( "-numeric-version", NoArg (do hPutStrLn stderr version_str
1623                                      exitWith ExitSuccess))
1624
1625       ------- verbosity ----------------------------------------------------
1626   ,  ( "v"              , NoArg (writeIORef verbose True) )
1627   ,  ( "n"              , NoArg (writeIORef dry_run True) )
1628
1629         ------- recompilation checker --------------------------------------
1630   ,  ( "recomp"         , NoArg (writeIORef recomp True) )
1631   ,  ( "no-recomp"      , NoArg (writeIORef recomp False) )
1632
1633         ------- ways --------------------------------------------------------
1634   ,  ( "prof"           , NoArg (addNoDups ways WayProf) )
1635   ,  ( "unreg"          , NoArg (addNoDups ways WayUnreg) )
1636   ,  ( "ticky"          , NoArg (addNoDups ways WayTicky) )
1637   ,  ( "parallel"       , NoArg (addNoDups ways WayPar) )
1638   ,  ( "gransim"        , NoArg (addNoDups ways WayGran) )
1639   ,  ( "smp"            , NoArg (addNoDups ways WaySMP) )
1640   ,  ( "debug"          , NoArg (addNoDups ways WayDebug) )
1641         -- ToDo: user ways
1642
1643         ------- Interface files ---------------------------------------------
1644   ,  ( "hi"             , NoArg (writeIORef produceHi True) )
1645   ,  ( "nohi"           , NoArg (writeIORef produceHi False) )
1646   ,  ( "hi-diffs"       , NoArg (writeIORef hi_diffs  NormalHiDiffs) )
1647   ,  ( "no-hi-diffs"    , NoArg (writeIORef hi_diffs  NoHiDiffs) )
1648   ,  ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
1649   ,  ( "keep-hi-diffs"  , NoArg (writeIORef keep_hi_diffs True) )
1650         --"hi-with-*"    -> hiw <- readIORef hi_with  (ToDo)
1651
1652         --------- Profiling --------------------------------------------------
1653   ,  ( "auto-dicts"     , NoArg (add opt_C "-fauto-sccs-on-dicts") )
1654   ,  ( "auto-all"       , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") )
1655   ,  ( "auto"           , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") )
1656   ,  ( "caf-all"        , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") )
1657          -- "ignore-sccs"  doesn't work  (ToDo)
1658
1659         ------- Miscellaneous -----------------------------------------------
1660   ,  ( "cpp"            , NoArg (writeIORef cpp_flag True) )
1661   ,  ( "#include"       , HasArg (add cmdline_hc_includes) )
1662   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
1663
1664         ------- Output Redirection ------------------------------------------
1665   ,  ( "odir"           , HasArg (writeIORef output_dir  . Just) )
1666   ,  ( "o"              , SepArg (writeIORef output_file . Just) )
1667   ,  ( "osuf"           , HasArg (writeIORef output_suf  . Just) )
1668   ,  ( "hisuf"          , HasArg (writeIORef hi_suf) )
1669   ,  ( "tmpdir"         , HasArg (writeIORef tmp_prefix  . (++ "/")) )
1670   ,  ( "ohi"            , HasArg (\s -> case s of 
1671                                           "-" -> writeIORef hi_on_stdout True
1672                                           _   -> writeIORef output_hi (Just s)) )
1673         -- -odump?
1674
1675   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef keep_hc_files True) )
1676   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef keep_s_files  True) )
1677   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files  True) )
1678
1679   ,  ( "split-objs"     , NoArg (if can_split
1680                                     then do writeIORef split_object_files True
1681                                             writeIORef hsc_lang HscC
1682                                             add opt_C "-fglobalise-toplev-names"
1683                                             add opt_c "-DUSE_SPLIT_MARKERS"
1684                                     else hPutStrLn stderr
1685                                             "warning: don't know how to  split \
1686                                             \object files on this architecture"
1687                                 ) )
1688   
1689         ------- Include/Import Paths ----------------------------------------
1690   ,  ( "i"              , OptPrefix augment_import_paths )
1691   ,  ( "I"              , Prefix augment_include_paths )
1692
1693         ------- Libraries ---------------------------------------------------
1694   ,  ( "L"              , Prefix augment_library_paths )
1695   ,  ( "l"              , Prefix (add cmdline_libraries) )
1696
1697         ------- Packages ----------------------------------------------------
1698   ,  ( "package-name"   , HasArg (\s -> add opt_C ("-inpackage="++s)) )
1699
1700   ,  ( "package"        , HasArg (addPackage) )
1701   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
1702
1703         ------- Specific phases  --------------------------------------------
1704   ,  ( "pgmdep"         , HasArg (writeIORef pgm_dep) )
1705   ,  ( "pgmL"           , HasArg (writeIORef pgm_L) )
1706   ,  ( "pgmP"           , HasArg (writeIORef pgm_P) )
1707   ,  ( "pgmC"           , HasArg (writeIORef pgm_C) )
1708   ,  ( "pgmc"           , HasArg (writeIORef pgm_c) )
1709   ,  ( "pgmm"           , HasArg (writeIORef pgm_m) )
1710   ,  ( "pgms"           , HasArg (writeIORef pgm_s) )
1711   ,  ( "pgma"           , HasArg (writeIORef pgm_a) )
1712   ,  ( "pgml"           , HasArg (writeIORef pgm_l) )
1713
1714   ,  ( "optdep"         , HasArg (add opt_dep) )
1715   ,  ( "optL"           , HasArg (add opt_L) )
1716   ,  ( "optP"           , HasArg (add opt_P) )
1717   ,  ( "optCrts"        , HasArg (add opt_Crts) )
1718   ,  ( "optC"           , HasArg (add opt_C) )
1719   ,  ( "optc"           , HasArg (add opt_c) )
1720   ,  ( "optm"           , HasArg (add opt_m) )
1721   ,  ( "opta"           , HasArg (add opt_a) )
1722   ,  ( "optl"           , HasArg (add opt_l) )
1723   ,  ( "optdll"         , HasArg (add opt_dll) )
1724
1725         ------ HsCpp opts ---------------------------------------------------
1726   ,  ( "D"              , Prefix (\s -> add opt_P ("-D'"++s++"'") ) )
1727   ,  ( "U"              , Prefix (\s -> add opt_P ("-U'"++s++"'") ) )
1728
1729         ------ Warning opts -------------------------------------------------
1730   ,  ( "W"              , NoArg (writeIORef warning_opt W_))
1731   ,  ( "Wall"           , NoArg (writeIORef warning_opt W_all))
1732   ,  ( "Wnot"           , NoArg (writeIORef warning_opt W_not))
1733   ,  ( "w"              , NoArg (writeIORef warning_opt W_not))
1734
1735         ----- Linker --------------------------------------------------------
1736   ,  ( "static"         , NoArg (writeIORef static True) )
1737
1738         ------ Compiler RTS options -----------------------------------------
1739   ,  ( "H"                 , HasArg (sizeOpt specific_heap_size) )
1740   ,  ( "K"                 , HasArg (sizeOpt specific_stack_size) )
1741   ,  ( "Rscale-sizes"      , HasArg (floatOpt scale_sizes_by) )
1742   ,  ( "Rghc-timing"       , NoArg (writeIORef collect_ghc_timing True) )
1743
1744         ------ Debugging ----------------------------------------------------
1745   ,  ( "dstg-stats"        , NoArg (writeIORef opt_StgStats True) )
1746
1747   ,  ( "dno-"              , Prefix (\s -> add anti_opt_C ("-d"++s)) )
1748   ,  ( "d"                 , AnySuffix (add opt_C) )
1749
1750         ------ Machine dependant (-m<blah>) stuff ---------------------------
1751
1752   ,  ( "monly-2-regs",          NoArg (writeIORef stolen_x86_regs 2) )
1753   ,  ( "monly-3-regs",          NoArg (writeIORef stolen_x86_regs 3) )
1754   ,  ( "monly-4-regs",          NoArg (writeIORef stolen_x86_regs 4) )
1755
1756         ------ Compiler flags -----------------------------------------------
1757   ,  ( "O2-for-C"          , NoArg (writeIORef opt_minus_o2_for_C True) )
1758   ,  ( "O"                 , OptPrefix (setOptLevel) )
1759
1760   ,  ( "fglasgow-exts-no-lang", NoArg ( do add opt_C "-fglasgow-exts") )
1761
1762   ,  ( "fglasgow-exts"     , NoArg (do add opt_C "-fglasgow-exts"
1763                                        addPackage "lang"))
1764
1765   ,  ( "fasm"              , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
1766
1767   ,  ( "fvia-C"            , NoArg (writeIORef hsc_lang HscC) )
1768
1769   ,  ( "fno-asm-mangling"  , NoArg (writeIORef do_asm_mangling False) )
1770
1771   ,  ( "fmax-simplifier-iterations", 
1772                 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
1773
1774   ,  ( "fusagesp",              NoArg (do writeIORef opt_UsageSPInf True
1775                                           add opt_C "-fusagesp-on") )
1776
1777         -- flags that are "active negatives"
1778   ,  ( "fno-implicit-prelude"   , PassFlag (add opt_C) )
1779   ,  ( "fno-prune-tydecls"      , PassFlag (add opt_C) )
1780   ,  ( "fno-prune-instdecls"    , PassFlag (add opt_C) )
1781   ,  ( "fno-pre-inlining"       , PassFlag (add opt_C) )
1782
1783         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
1784   ,  ( "fno-",                  Prefix (\s -> add anti_opt_C ("-f"++s)) )
1785
1786         -- Pass all remaining "-f<blah>" options to hsc
1787   ,  ( "f",                     AnySuffix (add opt_C) )
1788   ]
1789
1790 -----------------------------------------------------------------------------
1791 -- Process command-line  
1792
1793 processArgs :: [String] -> [String] -> IO [String]  -- returns spare args
1794 processArgs [] spare = return (reverse spare)
1795 processArgs args@(('-':_):_) spare = do
1796   args' <- processOneArg args
1797   processArgs args' spare
1798 processArgs (arg:args) spare = 
1799   processArgs args (arg:spare)
1800
1801 processOneArg :: [String] -> IO [String]
1802 processOneArg (('-':arg):args) = do
1803   let (rest,action) = findArg arg
1804       dash_arg = '-':arg
1805   case action of
1806
1807         NoArg  io -> 
1808                 if rest == ""
1809                         then io >> return args
1810                         else throwDyn (UnknownFlag dash_arg)
1811
1812         HasArg fio -> 
1813                 if rest /= "" 
1814                         then fio rest >> return args
1815                         else case args of
1816                                 [] -> throwDyn (UnknownFlag dash_arg)
1817                                 (arg1:args1) -> fio arg1 >> return args1
1818
1819         SepArg fio -> 
1820                 case args of
1821                         [] -> throwDyn (UnknownFlag dash_arg)
1822                         (arg1:args1) -> fio arg1 >> return args1
1823
1824         Prefix fio -> 
1825                 if rest /= ""
1826                         then fio rest >> return args
1827                         else throwDyn (UnknownFlag dash_arg)
1828         
1829         OptPrefix fio -> fio rest >> return args
1830
1831         AnySuffix fio -> fio ('-':arg) >> return args
1832
1833         PassFlag fio  -> 
1834                 if rest /= ""
1835                         then throwDyn (UnknownFlag dash_arg)
1836                         else fio ('-':arg) >> return args
1837
1838 findArg :: String -> (String,OptKind)
1839 findArg arg
1840   = case [ (remove_spaces rest, k) | (pat,k) <- opts, 
1841                                      Just rest <- [my_prefix_match pat arg],
1842                                      is_prefix k || null rest ] of
1843         [] -> throwDyn (UnknownFlag ('-':arg))
1844         (one:_) -> one
1845
1846 is_prefix (NoArg _) = False
1847 is_prefix (SepArg _) = False
1848 is_prefix (PassFlag _) = False
1849 is_prefix _ = True
1850
1851 -----------------------------------------------------------------------------
1852 -- convert sizes like "3.5M" into integers
1853
1854 sizeOpt :: IORef Integer -> String -> IO ()
1855 sizeOpt ref str
1856   | c == ""              = writeSizeOpt ref (truncate n)
1857   | c == "K" || c == "k" = writeSizeOpt ref (truncate (n * 1000))
1858   | c == "M" || c == "m" = writeSizeOpt ref (truncate (n * 1000 * 1000))
1859   | c == "G" || c == "g" = writeSizeOpt ref (truncate (n * 1000 * 1000 * 1000))
1860   | otherwise            = throwDyn (UnknownFlag str)
1861   where (m, c) = span pred str
1862         n      = read m  :: Double
1863         pred c = isDigit c || c == '.'
1864
1865 writeSizeOpt :: IORef Integer -> Integer -> IO ()
1866 writeSizeOpt ref new = do
1867   current <- readIORef ref
1868   if (new > current) 
1869         then writeIORef ref new
1870         else return ()
1871
1872 floatOpt :: IORef Double -> String -> IO ()
1873 floatOpt ref str
1874   = writeIORef ref (read str :: Double)
1875
1876 -----------------------------------------------------------------------------
1877 -- Finding files in the installation
1878
1879 GLOBAL_VAR(topDir, clibdir, String)
1880
1881         -- grab the last -B option on the command line, and
1882         -- set topDir to its value.
1883 setTopDir :: [String] -> IO [String]
1884 setTopDir args = do
1885   let (minusbs, others) = partition (prefixMatch "-B") args
1886   (case minusbs of
1887     []   -> writeIORef topDir clibdir
1888     some -> writeIORef topDir (drop 2 (last some)))
1889   return others
1890
1891 findFile name alt_path = unsafePerformIO (do
1892   top_dir <- readIORef topDir
1893   let installed_file = top_dir ++ '/':name
1894   let inplace_file   = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
1895   b <- fileExist inplace_file
1896   if b  then return inplace_file
1897         else return installed_file
1898  )
1899
1900 -----------------------------------------------------------------------------
1901 -- Utils
1902
1903 my_partition :: (a -> Maybe b) -> [a] -> ([b],[a])
1904 my_partition p [] = ([],[])
1905 my_partition p (a:as)
1906   = let (bs,cs) = my_partition p as in
1907     case p a of
1908         Nothing -> (bs,a:cs)
1909         Just b  -> (b:bs,cs)
1910
1911 my_prefix_match :: String -> String -> Maybe String
1912 my_prefix_match [] rest = Just rest
1913 my_prefix_match (p:pat) [] = Nothing
1914 my_prefix_match (p:pat) (r:rest)
1915   | p == r    = my_prefix_match pat rest
1916   | otherwise = Nothing
1917
1918 prefixMatch :: Eq a => [a] -> [a] -> Bool
1919 prefixMatch [] str = True
1920 prefixMatch pat [] = False
1921 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
1922                           | otherwise = False
1923
1924 postfixMatch :: String -> String -> Bool
1925 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
1926
1927 later = flip finally
1928
1929 on b io = if b then io >> return (error "on") else return (error "on")
1930
1931 my_catch = flip catchAllIO
1932 my_catchDyn = flip catchDyn
1933
1934 global :: a -> IORef a
1935 global a = unsafePerformIO (newIORef a)
1936
1937 split_filename :: String -> (String,String)
1938 split_filename f = (reverse rev_basename, reverse rev_ext)
1939   where (rev_ext, '.':rev_basename) = span ('.' /=) (reverse f)
1940
1941 split :: Char -> String -> [String]
1942 split c s = case rest of
1943                 []     -> [chunk] 
1944                 _:rest -> chunk : split c rest
1945   where (chunk, rest) = break (==c) s
1946
1947 add :: IORef [a] -> a -> IO ()
1948 add var x = do
1949   xs <- readIORef var
1950   writeIORef var (x:xs)
1951
1952 addNoDups :: Eq a => IORef [a] -> a -> IO ()
1953 addNoDups var x = do
1954   xs <- readIORef var
1955   if x `elem` xs then return () else writeIORef var (x:xs)
1956
1957 remove_suffix :: String -> Char -> String
1958 remove_suffix s c 
1959   | null pre  = reverse suf
1960   | otherwise = reverse pre
1961   where (suf,pre) = break (==c) (reverse s)
1962
1963 drop_longest_prefix :: String -> Char -> String
1964 drop_longest_prefix s c = reverse suf
1965   where (suf,pre) = break (==c) (reverse s)
1966
1967 take_longest_prefix :: String -> Char -> String
1968 take_longest_prefix s c = reverse pre
1969   where (suf,pre) = break (==c) (reverse s)
1970
1971 newsuf :: String -> String -> String
1972 newsuf suf s = remove_suffix s '.' ++ suf
1973
1974 -- getdir strips the filename off the input string, returning the directory.
1975 getdir :: String -> String
1976 getdir s = if null dir then "." else init dir
1977   where dir = take_longest_prefix s '/'
1978
1979 newdir :: String -> String -> String
1980 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
1981
1982 remove_spaces :: String -> String
1983 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace