1 -----------------------------------------------------------------------------
4 -- (c) Simon Marlow 2000
6 -----------------------------------------------------------------------------
8 module Main (main) where
27 #define GLOBAL_VAR(name,value,ty) \
28 name = global (value) :: IORef (ty); \
31 -----------------------------------------------------------------------------
34 -- time commands when run with -v
40 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
42 -----------------------------------------------------------------------------
43 -- Differences vs. old driver:
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)
48 -- no hi diffs (could be added later)
51 -----------------------------------------------------------------------------
52 -- non-configured things
54 _Haskell1Version = "5" -- i.e., Haskell 98
56 -----------------------------------------------------------------------------
60 hPutStr stderr "\nUsage: For basic information, try the `-help' option.\n"
64 let usage_dir = findFile "ghc-usage.txt" (_GHC_DRIVER_DIR++"/ghc-usage.txt")
65 usage <- readFile (usage_dir++"/ghc-usage.txt")
70 dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
71 dump (c:s) = hPutChar stderr c >> dump s
73 -----------------------------------------------------------------------------
77 Phase of the | Suffix saying | Flag saying | (suffix of)
78 compilation system | ``start here''| ``stop after''| output file
80 literate pre-processor | .lhs | - | -
81 C pre-processor (opt.) | - | -E | -
82 Haskell compiler | .hs | -C, -S | .hc, .s
83 C compiler (opt.) | .hc or .c | -S | .s
84 assembler | .s or .S | -c | .o
85 linker | other | - | a.out
89 = MkDependHS -- haskell dependency generation
94 | HCc -- Haskellised C (as opposed to vanilla C) compilation
95 | Mangle -- assembly mangling, now done by a separate script.
96 | SplitMangle -- after mangler if splitting
100 deriving (Eq,Ord,Enum,Ix,Show,Bounded)
102 initial_phase = Unlit
104 -----------------------------------------------------------------------------
108 = UnknownFileType String
111 | MultipleSrcsOneOutput
112 | UnknownPackage String
113 | WayCombinationNotSupported [WayName]
114 | PhaseFailed String ExitCode
119 GLOBAL_VAR(prog_name, "ghc", String)
121 get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
123 instance Show BarfKind where
125 = showString get_prog_name . showString ": " . showBarf e
127 showBarf AmbiguousPhase
128 = showString "only one of the flags -M, -E, -C, -S, -c is allowed"
129 showBarf (UnknownFileType s)
130 = showString "unknown file type, and linking not done: " . showString s
131 showBarf (UnknownFlag s)
132 = showString "unrecognised flag: " . showString s
133 showBarf MultipleSrcsOneOutput
134 = showString "can't apply -o option to multiple source files"
135 showBarf (UnknownPackage s)
136 = showString "unknown package name: " . showString s
137 showBarf (WayCombinationNotSupported ws)
138 = showString "combination not supported: "
139 . foldr1 (\a b -> a . showChar '/' . b)
140 (map (showString . wayName . lkupWay) ws)
141 showBarf (NoInputFiles)
142 = showString "no input files"
144 barfKindTc = mkTyCon "BarfKind"
146 instance Typeable BarfKind where
147 typeOf _ = mkAppTy barfKindTc []
149 -----------------------------------------------------------------------------
152 GLOBAL_VAR(files_to_clean, [], [String])
154 cleanTempFiles :: IO ()
156 fs <- readIORef files_to_clean
157 verb <- readIORef verbose
160 (do on verb (hPutStrLn stderr ("removing: " ++ f))
161 if '*' `elem` f then system ("rm -f " ++ f) >> return ()
164 (\e -> on verb (hPutStrLn stderr
165 ("warning: can't remove tmp file" ++ f)))
168 -----------------------------------------------------------------------------
169 -- Which phase to stop at
171 GLOBAL_VAR(stop_after, Ln, Phase)
173 end_phase_flag :: String -> Maybe Phase
174 end_phase_flag "-M" = Just MkDependHS
175 end_phase_flag "-E" = Just Cpp
176 end_phase_flag "-C" = Just Hsc
177 end_phase_flag "-S" = Just Mangle
178 end_phase_flag "-c" = Just As
179 end_phase_flag _ = Nothing
181 getStopAfter :: [String]
182 -> IO ( [String] -- rest of command line
183 , Phase -- stop after phase
184 , Bool -- do linking?
187 = case my_partition end_phase_flag flags of
188 ([] , rest) -> return (rest, As, True)
189 ([one], rest) -> return (rest, one, False)
190 (_ , rest) -> throwDyn AmbiguousPhase
192 -----------------------------------------------------------------------------
193 -- Global compilation flags
196 GLOBAL_VAR(cpp_flag, False, Bool)
197 hs_source_cpp_opts = global
198 [ "-D__HASKELL1__="++_Haskell1Version
199 , "-D__GLASGOW_HASKELL__="++_ProjectVersionInt
201 , "-D__CONCURRENT_HASKELL__"
204 -- Keep output from intermediate phases
205 GLOBAL_VAR(keep_hi_diffs, False, Bool)
206 GLOBAL_VAR(keep_hc_files, False, Bool)
207 GLOBAL_VAR(keep_s_files, False, Bool)
208 GLOBAL_VAR(keep_raw_s_files, False, Bool)
210 -- Compiler RTS options
211 GLOBAL_VAR(specific_heap_size, 6 * 1000 * 1000, Integer)
212 GLOBAL_VAR(specific_stack_size, 1000 * 1000, Integer)
213 GLOBAL_VAR(scale_sizes_by, 1.0, Double)
216 GLOBAL_VAR(verbose, False, Bool)
217 is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
220 GLOBAL_VAR(dry_run, False, Bool)
221 GLOBAL_VAR(recomp, True, Bool)
222 GLOBAL_VAR(tmp_prefix, _TMPDIR, String)
223 GLOBAL_VAR(stolen_x86_regs, 4, Int)
224 GLOBAL_VAR(static, True, Bool) -- ToDo: not for mingw32
225 GLOBAL_VAR(collect_ghc_timing, False, Bool)
226 GLOBAL_VAR(do_asm_mangling, True, Bool)
228 -----------------------------------------------------------------------------
229 -- Splitting object files (for libraries)
231 GLOBAL_VAR(split_object_files, False, Bool)
232 GLOBAL_VAR(split_prefix, "", String)
233 GLOBAL_VAR(n_split_files, 0, Int)
236 can_split = prefixMatch "i386" _TARGETPLATFORM
237 || prefixMatch "alpha" _TARGETPLATFORM
238 || prefixMatch "hppa" _TARGETPLATFORM
239 || prefixMatch "m68k" _TARGETPLATFORM
240 || prefixMatch "mips" _TARGETPLATFORM
241 || prefixMatch "powerpc" _TARGETPLATFORM
242 || prefixMatch "rs6000" _TARGETPLATFORM
243 || prefixMatch "sparc" _TARGETPLATFORM
245 -----------------------------------------------------------------------------
246 -- Compiler output options
253 GLOBAL_VAR(hsc_lang, if _GhcWithNativeCodeGen == "YES" &&
254 prefixMatch "i386" _TARGETPLATFORM
259 GLOBAL_VAR(output_dir, Nothing, Maybe String)
260 GLOBAL_VAR(output_suf, Nothing, Maybe String)
261 GLOBAL_VAR(output_file, Nothing, Maybe String)
262 GLOBAL_VAR(output_hi, Nothing, Maybe String)
264 GLOBAL_VAR(ld_inputs, [], [String])
266 odir_ify :: String -> IO String
268 odir_opt <- readIORef output_dir
271 Just d -> return (newdir f d)
273 osuf_ify :: String -> IO String
275 osuf_opt <- readIORef output_suf
278 Just s -> return (newsuf f s)
280 -----------------------------------------------------------------------------
283 GLOBAL_VAR(produceHi, True, Bool)
284 GLOBAL_VAR(hi_on_stdout, False, Bool)
285 GLOBAL_VAR(hi_with, "", String)
286 GLOBAL_VAR(hi_suf, "hi", String)
288 data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs
289 GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag)
291 -----------------------------------------------------------------------------
292 -- Warnings & sanity checking
294 -- Warning packages that are controlled by -W and -Wall. The 'standard'
295 -- warnings that you get all the time are
297 -- -fwarn-overlapping-patterns
298 -- -fwarn-missing-methods
299 -- -fwarn-missing-fields
300 -- -fwarn-deprecations
301 -- -fwarn-duplicate-exports
303 -- these are turned off by -Wnot.
305 standardWarnings = [ "-fwarn-overlapping-patterns"
306 , "-fwarn-missing-methods"
307 , "-fwarn-missing-fields"
308 , "-fwarn-deprecations"
309 , "-fwarn-duplicate-exports"
311 minusWOpts = standardWarnings ++
312 [ "-fwarn-unused-binds"
313 , "-fwarn-unused-matches"
314 , "-fwarn-incomplete-patterns"
315 , "-fwarn-unused-imports"
317 minusWallOpts = minusWOpts ++
318 [ "-fwarn-type-defaults"
319 , "-fwarn-name-shadowing"
320 , "-fwarn-missing-signatures"
323 data WarningState = W_default | W_ | W_all | W_not
325 GLOBAL_VAR(warning_opt, W_default, WarningState)
327 -----------------------------------------------------------------------------
328 -- Compiler optimisation options
330 GLOBAL_VAR(opt_level, 0, Int)
332 setOptLevel :: String -> IO ()
333 setOptLevel "" = do { writeIORef opt_level 1; go_via_C }
334 setOptLevel "not" = writeIORef opt_level 0
335 setOptLevel [c] | isDigit c = do
336 let level = ord c - ord '0'
337 writeIORef opt_level level
338 on (level >= 1) go_via_C
339 setOptLevel s = throwDyn (UnknownFlag ("-O"++s))
342 l <- readIORef hsc_lang
343 case l of { HscAsm -> writeIORef hsc_lang HscC;
344 _other -> return () }
346 GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
348 GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
349 GLOBAL_VAR(opt_StgStats, False, Bool)
350 GLOBAL_VAR(opt_UsageSPInf, False, Bool) -- Off by default
352 hsc_minusO2_flags = hsc_minusO_flags -- for now
354 hsc_minusNoO_flags = do
355 iter <- readIORef opt_MaxSimplifierIterations
357 "-fignore-interface-pragmas",
358 "-fomit-interface-pragmas",
361 "-fmax-simplifier-iterations" ++ show iter,
365 hsc_minusO_flags = do
366 iter <- readIORef opt_MaxSimplifierIterations
367 usageSP <- readIORef opt_UsageSPInf
368 stgstats <- readIORef opt_StgStats
373 "-fdo-eta-reduction",
374 "-fdo-lambda-eta-expansion",
379 -- initial simplify: mk specialiser happy: minimum effort please
384 -- Don't inline anything till full laziness has bitten
385 -- In particular, inlining wrappers inhibits floating
386 -- e.g. ...(case f x of ...)...
387 -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
388 -- ==> ...(case x of I# x# -> case fw x# of ...)...
389 -- and now the redex (f x) isn't floatable any more
392 -- Similarly, don't apply any rules until after full
393 -- laziness. Notably, list fusion can prevent floating.
396 -- Don't do case-of-case transformations.
397 -- This makes full laziness work better
399 "-fmax-simplifier-iterations2",
402 -- Specialisation is best done before full laziness
403 -- so that overloaded functions have all their dictionary lambdas manifest
412 -- Want to run with inline phase 1 after the specialiser to give
413 -- maximum chance for fusion to work before we inline build/augment
414 -- in phase 2. This made a difference in 'ansi' where an
415 -- overloaded function wasn't inlined till too late.
416 "-fmax-simplifier-iterations" ++ show iter,
419 -- infer usage information here in case we need it later.
420 -- (add more of these where you need them --KSW 1999-04)
421 if usageSP then "-fusagesp" else "",
425 -- Need inline-phase2 here so that build/augment get
426 -- inlined. I found that spectral/hartel/genfft lost some useful
427 -- strictness in the function sumcode' if augment is not inlined
428 -- before strictness analysis runs
431 "-fmax-simplifier-iterations2",
437 "-fmax-simplifier-iterations2",
438 -- No -finline-phase: allow all Ids to be inlined now
439 -- This gets foldr inlined before strictness analysis
448 "-fmax-simplifier-iterations" ++ show iter,
449 -- No -finline-phase: allow all Ids to be inlined now
453 -- nofib/spectral/hartel/wang doubles in speed if you
454 -- do full laziness late in the day. It only happens
455 -- after fusion and other stuff, so the early pass doesn't
456 -- catch it. For the record, the redex is
457 -- f_el22 (f_el21 r_midblock)
459 -- Leave out lambda lifting for now
460 -- "-fsimplify", -- Tidy up results of full laziness
462 -- "-fmax-simplifier-iterations2",
464 -- "-ffloat-outwards-full",
466 -- We want CSE to follow the final full-laziness pass, because it may
467 -- succeed in commoning up things floated out by full laziness.
469 -- CSE must immediately follow a simplification pass, because it relies
470 -- on the no-shadowing invariant. See comments at the top of CSE.lhs
471 -- So it must NOT follow float-inwards, which can give rise to shadowing,
472 -- even if its input doesn't have shadows. Hence putting it between
479 -- Case-liberation for -O2. This should be after
480 -- strictness analysis and the simplification which follows it.
482 -- ( ($OptLevel != 2)
484 -- : "-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 ]" ),
486 -- "-fliberate-case",
488 -- Final clean-up simplification:
491 "-fmax-simplifier-iterations" ++ show iter,
492 -- No -finline-phase: allow all Ids to be inlined now
497 -----------------------------------------------------------------------------
500 split_marker = ':' -- not configurable
502 import_paths, include_paths, library_paths :: IORef [String]
503 GLOBAL_VAR(import_paths, ["."], [String])
504 GLOBAL_VAR(include_paths, ["."], [String])
505 GLOBAL_VAR(library_paths, [], [String])
507 GLOBAL_VAR(cmdline_libraries, [], [String])
508 GLOBAL_VAR(cmdline_hc_includes, [], [String])
510 augment_import_paths :: String -> IO ()
511 augment_import_paths "" = writeIORef import_paths []
512 augment_import_paths path
513 = do paths <- readIORef import_paths
514 writeIORef import_paths (paths ++ dirs)
515 where dirs = split split_marker path
517 augment_include_paths :: String -> IO ()
518 augment_include_paths path
519 = do paths <- readIORef include_paths
520 writeIORef include_paths (paths ++ split split_marker path)
522 augment_library_paths :: String -> IO ()
523 augment_library_paths path
524 = do paths <- readIORef library_paths
525 writeIORef library_paths (paths ++ split split_marker path)
527 -----------------------------------------------------------------------------
530 -- package list is maintained in dependency order
531 packages = global ["std", "rts", "gmp"] :: IORef [String]
532 -- comma in value, so can't use macro, grrr
533 {-# NOINLINE packages #-}
535 addPackage :: String -> IO ()
537 = do pkg_details <- readIORef package_details
538 case lookup package pkg_details of
539 Nothing -> throwDyn (UnknownPackage package)
541 ps <- readIORef packages
544 else do mapM_ addPackage (package_deps details)
545 ps <- readIORef packages
546 writeIORef packages (package:ps)
548 getPackageImportPath :: IO [String]
549 getPackageImportPath = do
550 ps <- readIORef packages
551 ps' <- getPackageDetails ps
552 return (nub (concat (map import_dirs ps')))
554 getPackageIncludePath :: IO [String]
555 getPackageIncludePath = do
556 ps <- readIORef packages
557 ps' <- getPackageDetails ps
558 return (nub (filter (not.null) (map include_dir ps')))
560 -- includes are in reverse dependency order (i.e. rts first)
561 getPackageCIncludes :: IO [String]
562 getPackageCIncludes = do
563 ps <- readIORef packages
564 ps' <- getPackageDetails ps
565 return (reverse (nub (filter (not.null) (map c_include ps'))))
567 getPackageLibraryPath :: IO [String]
568 getPackageLibraryPath = do
569 ps <- readIORef packages
570 ps' <- getPackageDetails ps
571 return (nub (concat (map library_dirs ps')))
573 getPackageLibraries :: IO [String]
574 getPackageLibraries = do
575 ps <- readIORef packages
576 ps' <- getPackageDetails ps
577 tag <- readIORef build_tag
578 let suffix = if null tag then "" else '_':tag
579 return (concat (map libraries ps'))
581 getPackageExtraGhcOpts :: IO [String]
582 getPackageExtraGhcOpts = do
583 ps <- readIORef packages
584 ps' <- getPackageDetails ps
585 return (map extra_ghc_opts ps')
587 getPackageExtraCcOpts :: IO [String]
588 getPackageExtraCcOpts = do
589 ps <- readIORef packages
590 ps' <- getPackageDetails ps
591 return (map extra_cc_opts ps')
593 getPackageExtraLdOpts :: IO [String]
594 getPackageExtraLdOpts = do
595 ps <- readIORef packages
596 ps' <- getPackageDetails ps
597 return (map extra_ld_opts ps')
599 getPackageDetails ps = do
600 pkg_details <- readIORef package_details
601 let getDetails p = case lookup p pkg_details of
602 Just details -> return details
603 Nothing -> error "getPackageDetails"
606 GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
608 -----------------------------------------------------------------------------
611 -- The central concept of a "way" is that all objects in a given
612 -- program must be compiled in the same "way". Certain options change
613 -- parameters of the virtual machine, eg. profiling adds an extra word
614 -- to the object header, so profiling objects cannot be linked with
615 -- non-profiling objects.
617 -- After parsing the command-line options, we determine which "way" we
618 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
620 -- We then find the "build-tag" associated with this way, and this
621 -- becomes the suffix used to find .hi files and libraries used in
624 GLOBAL_VAR(build_tag, "", String)
653 GLOBAL_VAR(ways, [] ,[WayName])
655 allowed_combinations =
656 [ [WayProf,WayUnreg],
657 [WayProf,WaySMP] -- works???
660 findBuildTag :: IO [String] -- new options
662 way_names <- readIORef ways
663 case sort way_names of
664 [] -> do writeIORef build_tag ""
667 [w] -> do let details = lkupWay w
668 writeIORef build_tag (wayTag details)
669 return (wayOpts details)
671 ws -> if ws `notElem` allowed_combinations
672 then throwDyn (WayCombinationNotSupported ws)
673 else let stuff = map lkupWay ws
674 tag = concat (map wayTag stuff)
675 flags = map wayOpts stuff
677 writeIORef build_tag tag
678 return (concat flags)
681 case lookup w way_details of
682 Nothing -> error "findBuildTag"
683 Just details -> details
691 way_details :: [ (WayName, Way) ]
693 [ (WayProf, Way "p" "Profiling"
696 , "-optc-DPROFILING" ]),
698 (WayTicky, Way "t" "Ticky-ticky Profiling"
701 , "-optc-DTICKY_TICKY" ]),
703 (WayUnreg, Way "u" "Unregisterised"
705 , "-optc-DUSE_MINIINTERPRETER"
706 , "-fno-asm-mangling"
707 , "-funregisterised" ]),
709 (WayPar, Way "mp" "Parallel"
712 , "-D__PARALLEL_HASKELL__"
714 , "-package concurrent" ]),
716 (WayGran, Way "mg" "Gransim"
721 , "-package concurrent" ]),
723 (WaySMP, Way "s" "SMP"
729 (WayUser_a, Way "a" "User way 'a'" ["$WAY_a_REAL_OPTS"]),
730 (WayUser_b, Way "b" "User way 'b'" ["$WAY_b_REAL_OPTS"]),
731 (WayUser_c, Way "c" "User way 'c'" ["$WAY_c_REAL_OPTS"]),
732 (WayUser_d, Way "d" "User way 'd'" ["$WAY_d_REAL_OPTS"]),
733 (WayUser_e, Way "e" "User way 'e'" ["$WAY_e_REAL_OPTS"]),
734 (WayUser_f, Way "f" "User way 'f'" ["$WAY_f_REAL_OPTS"]),
735 (WayUser_g, Way "g" "User way 'g'" ["$WAY_g_REAL_OPTS"]),
736 (WayUser_h, Way "h" "User way 'h'" ["$WAY_h_REAL_OPTS"]),
737 (WayUser_i, Way "i" "User way 'i'" ["$WAY_i_REAL_OPTS"]),
738 (WayUser_j, Way "j" "User way 'j'" ["$WAY_j_REAL_OPTS"]),
739 (WayUser_k, Way "k" "User way 'k'" ["$WAY_k_REAL_OPTS"]),
740 (WayUser_l, Way "l" "User way 'l'" ["$WAY_l_REAL_OPTS"]),
741 (WayUser_m, Way "m" "User way 'm'" ["$WAY_m_REAL_OPTS"]),
742 (WayUser_n, Way "n" "User way 'n'" ["$WAY_n_REAL_OPTS"]),
743 (WayUser_o, Way "o" "User way 'o'" ["$WAY_o_REAL_OPTS"]),
744 (WayUser_A, Way "A" "User way 'A'" ["$WAY_A_REAL_OPTS"]),
745 (WayUser_B, Way "B" "User way 'B'" ["$WAY_B_REAL_OPTS"])
748 -----------------------------------------------------------------------------
749 -- Programs for particular phases
751 GLOBAL_VAR(pgm_dep, findFile "mkdependHS" _GHC_MKDEPENDHS, String)
752 GLOBAL_VAR(pgm_L, findFile "unlit" _GHC_UNLIT, String)
753 GLOBAL_VAR(pgm_P, findFile "hscpp" _GHC_HSCPP, String)
754 GLOBAL_VAR(pgm_C, findFile "hsc" _GHC_HSC, String)
755 GLOBAL_VAR(pgm_c, _GCC, String)
756 GLOBAL_VAR(pgm_m, findFile "ghc-asm" _GHC_MANGLER, String)
757 GLOBAL_VAR(pgm_s, findFile "ghc-split" _GHC_SPLIT, String)
758 GLOBAL_VAR(pgm_a, _GCC, String)
759 GLOBAL_VAR(pgm_l, _GCC, String)
761 -----------------------------------------------------------------------------
762 -- Options for particular phases
764 GLOBAL_VAR(opt_dep, [], [String])
765 GLOBAL_VAR(opt_L, [], [String])
766 GLOBAL_VAR(opt_P, [], [String])
767 GLOBAL_VAR(opt_C, [], [String])
768 GLOBAL_VAR(opt_Crts, [], [String])
769 GLOBAL_VAR(opt_c, [], [String])
770 GLOBAL_VAR(opt_a, [], [String])
771 GLOBAL_VAR(opt_m, [], [String])
772 GLOBAL_VAR(opt_l, [], [String])
773 GLOBAL_VAR(opt_dll, [], [String])
775 -- we add to the options from the front, so we need to reverse the list
776 getOpts :: IORef [String] -> IO [String]
777 getOpts opts = readIORef opts >>= return . reverse
779 GLOBAL_VAR(anti_opt_C, [], [String])
781 -----------------------------------------------------------------------------
782 -- Via-C compilation stuff
784 -- flags returned are: ( all C compilations
785 -- , registerised HC compilations
789 | prefixMatch "alpha" _TARGETPLATFORM
790 = return ( ["-static"], [] )
792 | prefixMatch "hppa" _TARGETPLATFORM
793 -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
794 -- (very nice, but too bad the HP /usr/include files don't agree.)
795 = return ( ["-static", "-D_HPUX_SOURCE"], [] )
797 | prefixMatch "m68k" _TARGETPLATFORM
798 -- -fno-defer-pop : for the .hc files, we want all the pushing/
799 -- popping of args to routines to be explicit; if we let things
800 -- be deferred 'til after an STGJUMP, imminent death is certain!
802 -- -fomit-frame-pointer : *don't*
803 -- It's better to have a6 completely tied up being a frame pointer
804 -- rather than let GCC pick random things to do with it.
805 -- (If we want to steal a6, then we would try to do things
806 -- as on iX86, where we *do* steal the frame pointer [%ebp].)
807 = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
809 | prefixMatch "i386" _TARGETPLATFORM
810 -- -fno-defer-pop : basically the same game as for m68k
812 -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
813 -- the fp (%ebp) for our register maps.
814 = do n_regs <- readIORef stolen_x86_regs
815 sta <- readIORef static
816 return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
817 [ "-fno-defer-pop", "-fomit-frame-pointer",
818 "-DSTOLEN_X86_REGS="++show n_regs ]
821 | prefixMatch "mips" _TARGETPLATFORM
822 = return ( ["static"], [] )
824 | prefixMatch "powerpc" _TARGETPLATFORM || prefixMatch "rs6000" _TARGETPLATFORM
825 = return ( ["static"], ["-finhibit-size-directive"] )
830 -----------------------------------------------------------------------------
831 -- Build the Hsc command line
833 build_hsc_opts :: IO [String]
835 opt_C_ <- getOpts opt_C -- misc hsc opts
838 warn_level <- readIORef warning_opt
839 let warn_opts = case warn_level of
840 W_default -> standardWarnings
842 W_all -> minusWallOpts
846 minus_o <- readIORef opt_level
849 0 -> hsc_minusNoO_flags
850 1 -> hsc_minusO_flags
851 2 -> hsc_minusO2_flags
855 ways_ <- readIORef ways
856 let stg_massage | WayProf `elem` ways_ = "-fmassage-stg-for-profiling"
859 stg_stats <- readIORef opt_StgStats
860 let stg_stats_flag | stg_stats = "-dstg-stats"
863 let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
864 -- let-no-escape always on for now
867 let hi_vers = "-fhi-version="++_ProjectVersionInt
868 static <- (do s <- readIORef static; if s then return "-static" else return "")
870 l <- readIORef hsc_lang
873 HscAsm -> "-olang=asm"
874 HscJava -> "-olang=java"
876 -- get hi-file suffix
877 hisuf <- readIORef hi_suf
879 -- hi-suffix for packages depends on the build tag.
881 do tag <- readIORef build_tag
884 else return (tag ++ "_hi")
886 import_dirs <- readIORef import_paths
887 package_import_dirs <- getPackageImportPath
889 let hi_map = "-himap=" ++
890 makeHiMap import_dirs hisuf
891 package_import_dirs package_hisuf
894 hi_map_sep = "-himap-sep=" ++ [split_marker]
896 scale <- readIORef scale_sizes_by
897 heap <- readIORef specific_heap_size
898 stack <- readIORef specific_stack_size
899 cmdline_rts_opts <- getOpts opt_Crts
900 let heap' = truncate (fromIntegral heap * scale) :: Integer
901 stack' = truncate (fromIntegral stack * scale) :: Integer
902 rts_opts = [ "+RTS", "-H"++show heap', "-K"++show stack' ]
903 ++ cmdline_rts_opts ++ [ "-RTS" ]
905 -- take into account -fno-* flags by removing the equivalent -f*
906 -- flag from our list.
907 anti_flags <- getOpts anti_opt_C
908 let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
909 filtered_opts = filter (`notElem` anti_flags) basic_opts
914 -- ToDo: C stub files
915 ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
920 (import_dirs :: [String])
921 (hi_suffix :: String)
922 (package_import_dirs :: [String])
923 (package_hi_suffix :: String)
924 (split_marker :: Char)
925 = foldr (add_dir hi_suffix)
926 (foldr (add_dir package_hi_suffix) "" package_import_dirs)
929 add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
933 :: String -- input file
934 -> IO [String] -- options, if any
935 getOptionsFromSource file
936 = do h <- openFile file ReadMode
942 () | null l -> look h
943 | prefixMatch "{-# LINE" l -> look h
944 | Just (opts:_) <- matchRegex optionRegex l
945 -> return (words opts)
946 | otherwise -> return []
948 optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}"
950 -----------------------------------------------------------------------------
953 get_source_files :: [String] -> ([String],[String])
954 get_source_files = partition (('-' /=) . head)
956 suffixes :: [(String,Phase)]
968 phase_input_ext Unlit = "lhs"
969 phase_input_ext Cpp = "lpp"
970 phase_input_ext Hsc = "cpp"
971 phase_input_ext HCc = "hc"
972 phase_input_ext Cc = "c"
973 phase_input_ext Mangle = "raw_s"
974 phase_input_ext SplitMangle = "split_s" -- not really generated
975 phase_input_ext As = "s"
976 phase_input_ext SplitAs = "split_s" -- not really generated
977 phase_input_ext Ln = "o"
979 find_phase :: String -> ([(Phase,String)], [String])
980 -> ([(Phase,String)], [String])
981 find_phase f (phase_srcs, unknown_srcs)
982 = case lookup ext suffixes of
983 Just the_phase -> ((the_phase,f):phase_srcs, unknown_srcs)
984 Nothing -> (phase_srcs, f:unknown_srcs)
985 where (basename,ext) = split_filename f
988 find_phases srcs = (phase_srcs, unknown_srcs)
989 where (phase_srcs, unknown_srcs) = foldr find_phase ([],[]) srcs
992 -- all error messages are propagated as exceptions
993 my_catchDyn (\dyn -> case dyn of
994 PhaseFailed phase code -> exitWith code
995 Interrupted -> exitWith (ExitFailure 1)
996 _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
997 exitWith (ExitFailure 1)) $
999 later cleanTempFiles $
1000 -- exceptions will be blocked while we clean the temporary files,
1001 -- so there shouldn't be any difficulty if we receive further
1005 -- install signal handlers
1006 main_thread <- myThreadId
1007 let sig_handler = Catch (raiseInThread main_thread
1008 (DynException (toDyn Interrupted)))
1009 installHandler sigQUIT sig_handler Nothing
1010 installHandler sigINT sig_handler Nothing
1013 writeIORef prog_name pgm
1017 -- grab any -B options from the command line first
1018 argv' <- setTopDir argv
1020 -- read the package configuration
1021 let conf = findFile "package.conf" (_GHC_DRIVER_DIR++"/package.conf.inplace")
1022 contents <- readFile conf
1023 writeIORef package_details (read contents)
1025 -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
1026 (flags2, stop_phase, do_linking) <- getStopAfter argv'
1028 -- process all the other arguments, and get the source files
1029 srcs <- processArgs flags2 []
1031 -- find the build tag, and re-process the build-specific options
1032 more_opts <- findBuildTag
1033 _ <- processArgs more_opts []
1035 if stop_phase == MkDependHS -- mkdependHS is special
1036 then do_mkdependHS flags2 srcs
1039 -- for each source file, find which phase to start at
1040 let (phase_srcs, unknown_srcs) = find_phases srcs
1042 o_file <- readIORef output_file
1043 if isJust o_file && not do_linking && length phase_srcs > 1
1044 then throwDyn MultipleSrcsOneOutput
1047 if null unknown_srcs && null phase_srcs
1048 then throwDyn NoInputFiles
1051 -- if we have unknown files, and we're not doing linking, complain
1052 -- (otherwise pass them through to the linker).
1053 if not (null unknown_srcs) && not do_linking
1054 then throwDyn (UnknownFileType (head unknown_srcs))
1057 let compileFile :: (Phase, String) -> IO String
1058 compileFile (phase, src) = do
1059 let (orig_base, _) = split_filename src
1060 if phase < Ln -- anything to do?
1061 then run_pipeline stop_phase do_linking True orig_base (phase,src)
1064 o_files <- mapM compileFile phase_srcs
1067 then do_link o_files unknown_srcs
1071 -- The following compilation pipeline algorithm is fairly hacky. A
1072 -- better way to do this would be to express the whole comilation as a
1073 -- data flow DAG, where the nodes are the intermediate files and the
1074 -- edges are the compilation phases. This framework would also work
1075 -- nicely if a haskell dependency generator was included in the
1078 -- It would also deal much more cleanly with compilation phases that
1079 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
1080 -- possibly stub files), where some of the output files need to be
1081 -- processed further (eg. the stub files need to be compiled by the C
1084 -- A cool thing to do would then be to execute the data flow graph
1085 -- concurrently, automatically taking advantage of extra processors on
1086 -- the host machine. For example, when compiling two Haskell files
1087 -- where one depends on the other, the data flow graph would determine
1088 -- that the C compiler from the first comilation can be overlapped
1089 -- with the hsc comilation for the second file.
1092 :: Phase -- phase to end on (never Linker)
1093 -> Bool -- doing linking afterward?
1094 -> Bool -- take into account -o when generating output?
1095 -> String -- original basename (eg. Main)
1096 -> (Phase, String) -- phase to run, input file
1097 -> IO String -- return final filename
1099 run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn)
1100 | phase > last_phase = return input_fn
1104 let (basename,ext) = split_filename input_fn
1106 split <- readIORef split_object_files
1107 mangle <- readIORef do_asm_mangling
1108 lang <- readIORef hsc_lang
1110 -- figure out what the next phase is. This is
1111 -- straightforward, apart from the fact that hsc can generate
1112 -- either C or assembler direct, and assembly mangling is
1120 HCc | mangle -> Mangle
1125 Mangle | not split -> As
1126 SplitMangle -> SplitAs
1132 -- filename extension for the output
1133 let new_ext = phase_input_ext next_phase
1135 -- Figure out what the output from this pass should be called.
1137 -- If we're keeping the output from this phase, then we just save
1138 -- it in the current directory, otherwise we generate a new temp file.
1139 keep_s <- readIORef keep_s_files
1140 keep_raw_s <- readIORef keep_raw_s_files
1141 keep_hc <- readIORef keep_hc_files
1142 let keep_this_output =
1145 Mangle | keep_raw_s -> True -- first enhancement :)
1147 Cc | keep_hc -> True
1151 (if phase == last_phase && not do_linking && use_ofile
1152 then do o_file <- readIORef output_file
1156 f <- odir_ify (orig_basename ++ '.':new_ext)
1159 -- .o files are always kept. .s files and .hc file may be kept.
1160 else if keep_this_output
1161 then odir_ify (orig_basename ++ '.':new_ext)
1162 else do filename <- newTempName new_ext
1163 add files_to_clean filename
1167 run_phase phase orig_basename input_fn output_fn
1169 run_pipeline last_phase do_linking use_ofile
1170 orig_basename (next_phase, output_fn)
1173 -- find a temporary name that doesn't already exist.
1174 newTempName :: String -> IO String
1175 newTempName extn = do
1177 tmp_dir <- readIORef tmp_prefix
1178 findTempName tmp_dir x
1179 where findTempName tmp_dir x = do
1180 let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
1181 b <- fileExist filename
1182 if b then findTempName tmp_dir (x+1)
1183 else return filename
1185 -------------------------------------------------------------------------------
1188 do_mkdependHS :: [String] -> [String] -> IO ()
1189 do_mkdependHS cmd_opts srcs = do
1190 -- ToDo: push (@MkDependHS_flags, "-o$Osuffix") if $Osuffix;
1191 -- # They're not (currently) needed, but we need to quote any -#include options
1192 -- foreach (@Cmd_opts) {
1193 -- s/-#include.*$/'$&'/g;
1196 mkdependHS <- readIORef pgm_dep
1197 mkdependHS_opts <- getOpts opt_dep
1198 hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1200 run_something "Dependency generation"
1201 (unwords (mkdependHS :
1204 ++ ("--" : cmd_opts )
1208 -------------------------------------------------------------------------------
1211 run_phase Unlit basename input_fn output_fn
1212 = do unlit <- readIORef pgm_L
1213 unlit_flags <- getOpts opt_L
1214 run_something "Literate pre-processor"
1215 ("echo '{-# LINE 1 \"" ++input_fn++"\" -}' > "++output_fn++" && "
1216 ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
1218 -------------------------------------------------------------------------------
1221 run_phase Cpp basename input_fn output_fn
1222 = do src_opts <- getOptionsFromSource input_fn
1223 processArgs src_opts []
1225 do_cpp <- readIORef cpp_flag
1228 cpp <- readIORef pgm_P
1229 hscpp_opts <- getOpts opt_P
1230 hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1232 cmdline_include_paths <- readIORef include_paths
1233 pkg_include_dirs <- getPackageIncludePath
1234 let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
1235 ++ pkg_include_dirs)
1238 run_something "C pre-processor"
1240 (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
1245 ++ [ input_fn, ">>", output_fn ]
1248 run_something "Inefective C pre-processor"
1249 ("echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}' > "
1250 ++ output_fn ++ " && cat " ++ input_fn
1251 ++ " >> " ++ output_fn)
1253 -----------------------------------------------------------------------------
1256 run_phase Hsc basename input_fn output_fn
1257 = do hsc <- readIORef pgm_C
1259 -- we add the current directory (i.e. the directory in which
1260 -- the .hs files resides) to the import path, since this is
1261 -- what gcc does, and it's probably what you want.
1262 let (root,dir) = break (=='/') (reverse basename)
1263 current_dir = if null dir then "." else reverse dir
1265 paths <- readIORef include_paths
1266 writeIORef include_paths (current_dir : paths)
1268 -- build the hsc command line
1269 hsc_opts <- build_hsc_opts
1271 doing_hi <- readIORef produceHi
1272 tmp_hi_file <- if doing_hi
1273 then do fn <- newTempName "hi"
1274 add files_to_clean fn
1278 let hi_flag = if doing_hi then "-hifile=" ++ tmp_hi_file
1281 -- deal with -Rghc-timing
1282 timing <- readIORef collect_ghc_timing
1283 stat_file <- newTempName "stat"
1284 add files_to_clean stat_file
1285 let stat_opts | timing = [ "+RTS", "-S"++stat_file, "-RTS" ]
1288 -- tmp files for foreign export stub code
1289 tmp_stub_h <- newTempName "stub_h"
1290 tmp_stub_c <- newTempName "stub_c"
1291 add files_to_clean tmp_stub_h
1292 add files_to_clean tmp_stub_c
1294 run_something "Haskell Compiler"
1295 (unwords (hsc : input_fn : (
1297 ++ [ hi_flag, " -ofile="++output_fn ]
1298 ++ [ "-F="++tmp_stub_c, "-FH="++tmp_stub_h ]
1302 -- Copy the .hi file into the current dir if it changed
1304 (do ohi <- readIORef output_hi
1305 hisuf <- readIORef hi_suf
1306 let hi_target = case ohi of
1307 Nothing -> basename ++ '.':hisuf
1309 new_hi_file <- fileExist tmp_hi_file
1311 (run_something "Copy hi file"
1312 (unwords ["mv", tmp_hi_file, hi_target]))
1315 -- Generate -Rghc-timing info
1317 run_something "Generate timing stats"
1318 (findFile "ghc-stats" _GHC_STATS ++ ' ':stat_file)
1322 let stub_h = basename ++ "_stub.h"
1323 let stub_c = basename ++ "_stub.c"
1325 -- copy .h_stub file into current dir if present
1326 b <- fileExist tmp_stub_h
1328 run_something "Copy stub .h file"
1329 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
1331 -- #include <..._stub.h> in .hc file
1332 add cmdline_hc_includes tmp_stub_h -- hack
1334 -- copy the _stub.c file into the current dir
1335 run_something "Copy stub .c file"
1337 "rm -f", stub_c, "&&",
1338 "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
1339 "cat", tmp_stub_c, ">> ", stub_c
1342 -- compile the _stub.c file w/ gcc
1343 run_pipeline As False{-no linking-}
1344 False{-no -o option-}
1348 add ld_inputs (basename++"_stub.o")
1351 -----------------------------------------------------------------------------
1354 -- we don't support preprocessing .c files (with -E) now. Doing so introduces
1355 -- way too many hacks, and I can't say I've ever used it anyway.
1357 run_phase cc_phase basename input_fn output_fn
1358 | cc_phase == Cc || cc_phase == HCc
1359 = do cc <- readIORef pgm_c
1360 cc_opts <- getOpts opt_c
1361 cmdline_include_dirs <- readIORef include_paths
1362 -- ToDo: $c_flags .= " -mno-cygwin" if ( $TargetPlatform =~ /-mingw32$/ );
1364 let hcc = cc_phase == HCc
1366 -- add package include paths even if we're just compiling
1367 -- .c files; this is the Value Add(TM) that using
1368 -- ghc instead of gcc gives you :)
1369 pkg_include_dirs <- getPackageIncludePath
1370 let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
1371 ++ pkg_include_dirs)
1373 c_includes <- getPackageCIncludes
1374 cmdline_includes <- readIORef cmdline_hc_includes -- -#include options
1376 let cc_injects | hcc = unlines (map mk_include
1377 (c_includes ++ reverse cmdline_includes))
1381 '"':_{-"-} -> "#include "++h_file
1382 '<':_ -> "#include "++h_file
1383 _ -> "#include \""++h_file++"\""
1385 cc_help <- newTempName "c"
1386 add files_to_clean cc_help
1387 h <- openFile cc_help WriteMode
1388 hPutStr h cc_injects
1389 hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
1392 ccout <- newTempName "ccout"
1393 add files_to_clean ccout
1395 mangle <- readIORef do_asm_mangling
1396 (md_c_flags, md_regd_c_flags) <- machdepCCOpts
1400 o2 <- readIORef opt_minus_o2_for_C
1401 let opt_flag | o2 = "-O2"
1404 pkg_extra_cc_opts <- getPackageExtraCcOpts
1406 run_something "C Compiler"
1407 (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
1409 ++ (if cc_phase == HCc && mangle
1410 then md_regd_c_flags
1412 ++ [ verb, "-S", "-Wimplicit", opt_flag ]
1413 ++ [ "-D__GLASGOW_HASKELL__="++_ProjectVersionInt ]
1416 ++ pkg_extra_cc_opts
1420 -- ToDo: postprocess the output from gcc
1422 -----------------------------------------------------------------------------
1425 run_phase Mangle basename input_fn output_fn
1426 = do mangler <- readIORef pgm_m
1427 mangler_opts <- getOpts opt_m
1429 if (prefixMatch "i386" _TARGETPLATFORM)
1430 then do n_regs <- readIORef stolen_x86_regs
1431 return [ show n_regs ]
1433 run_something "Assembly Mangler"
1436 ++ [ input_fn, output_fn ]
1440 -----------------------------------------------------------------------------
1443 run_phase SplitMangle basename input_fn outputfn
1444 = do splitter <- readIORef pgm_s
1446 -- this is the prefix used for the split .s files
1447 tmp_pfx <- readIORef tmp_prefix
1449 let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1450 writeIORef split_prefix split_s_prefix
1451 add files_to_clean (split_s_prefix ++ "__*") -- d:-)
1453 -- allocate a tmp file to put the no. of split .s files in (sigh)
1454 n_files <- newTempName "n_files"
1455 add files_to_clean n_files
1457 run_something "Split Assembly File"
1464 -- save the number of split files for future references
1465 s <- readFile n_files
1466 let n = read s :: Int
1467 writeIORef n_split_files n
1469 -----------------------------------------------------------------------------
1472 run_phase As basename input_fn output_fn
1473 = do as <- readIORef pgm_a
1474 as_opts <- getOpts opt_a
1476 cmdline_include_paths <- readIORef include_paths
1477 let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1478 run_something "Assembler"
1479 (unwords (as : as_opts
1480 ++ cmdline_include_flags
1481 ++ [ "-c", input_fn, "-o", output_fn ]
1484 run_phase SplitAs basename input_fn output_fn
1485 = do as <- readIORef pgm_a
1486 as_opts <- getOpts opt_a
1488 odir_opt <- readIORef output_dir
1489 let odir | Just s <- odir_opt = s
1490 | otherwise = basename
1492 split_s_prefix <- readIORef split_prefix
1493 n <- readIORef n_split_files
1495 odir <- readIORef output_dir
1496 let real_odir = case odir of
1500 let assemble_file n = do
1501 let input_s = split_s_prefix ++ "__" ++ show n ++ ".s"
1502 let output_o = newdir real_odir
1503 (basename ++ "__" ++ show n ++ ".o")
1504 run_something "Assembler"
1505 (unwords (as : as_opts
1506 ++ [ "-c", "-o ", output_o, input_s ]
1509 mapM_ assemble_file [1..n]
1511 -----------------------------------------------------------------------------
1514 do_link :: [String] -> [String] -> IO ()
1515 do_link o_files unknown_srcs = do
1516 ln <- readIORef pgm_l
1518 o_file <- readIORef output_file
1519 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1521 pkg_lib_paths <- getPackageLibraryPath
1522 let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1524 lib_paths <- readIORef library_paths
1525 let lib_path_opts = map ("-L"++) lib_paths
1527 pkg_libs <- getPackageLibraries
1528 let pkg_lib_opts = map ("-l"++) pkg_libs
1530 libs <- readIORef cmdline_libraries
1531 let lib_opts = map ("-l"++) (reverse libs)
1532 -- reverse because they're added in reverse order from the cmd line
1534 pkg_extra_ld_opts <- getPackageExtraLdOpts
1536 -- probably _stub.o files
1537 extra_ld_inputs <- readIORef ld_inputs
1539 run_something "Linker"
1541 ([ ln, verb, "-o", output_fn ]
1542 -- ToDo: -u <blah> options
1548 ++ pkg_lib_path_opts
1550 ++ pkg_extra_ld_opts
1554 -----------------------------------------------------------------------------
1555 -- Running an external program
1557 run_something phase_name cmd
1559 verb <- readIORef verbose
1568 n <- readIORef dry_run
1569 if n then return () else do
1572 exit_code <- system cmd `catchAllIO`
1573 (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
1575 if exit_code /= ExitSuccess
1576 then throwDyn (PhaseFailed phase_name exit_code)
1577 else do on verb (putStr "\n")
1580 -----------------------------------------------------------------------------
1584 = NoArg (IO ()) -- flag with no argument
1585 | HasArg (String -> IO ()) -- flag has an argument (maybe prefix)
1586 | SepArg (String -> IO ()) -- flag has a separate argument
1587 | Prefix (String -> IO ()) -- flag is a prefix only
1588 | OptPrefix (String -> IO ()) -- flag may be a prefix
1589 | AnySuffix (String -> IO ()) -- flag is a prefix, pass whole arg to fn
1590 | PassFlag (String -> IO ()) -- flag with no arg, pass flag to fn
1593 [ ------- help -------------------------------------------------------
1594 ( "?" , NoArg long_usage)
1595 , ( "-help" , NoArg long_usage)
1598 ------- version ----------------------------------------------------
1599 , ( "-version" , NoArg (do hPutStrLn stderr (_ProjectName
1600 ++ ", version " ++ _ProjectVersion
1601 ++ ", patchlevel " ++ _ProjectPatchLevel)
1602 exitWith ExitSuccess))
1604 ------- verbosity ----------------------------------------------------
1605 , ( "v" , NoArg (writeIORef verbose True) )
1606 , ( "n" , NoArg (writeIORef dry_run True) )
1608 ------- recompilation checker --------------------------------------
1609 , ( "recomp" , NoArg (writeIORef recomp True) )
1610 , ( "no-recomp" , NoArg (writeIORef recomp False) )
1612 ------- ways --------------------------------------------------------
1613 , ( "prof" , NoArg (add ways WayProf) )
1614 , ( "unreg" , NoArg (add ways WayUnreg) )
1615 , ( "ticky" , NoArg (add ways WayTicky) )
1616 , ( "parallel" , NoArg (add ways WayPar) )
1617 , ( "gransim" , NoArg (add ways WayGran) )
1618 , ( "smp" , NoArg (add ways WaySMP) )
1619 , ( "debug" , NoArg (add ways WayDebug) )
1622 ------- Interface files ---------------------------------------------
1623 , ( "hi" , NoArg (writeIORef produceHi True) )
1624 , ( "nohi" , NoArg (writeIORef produceHi False) )
1625 , ( "hi-diffs" , NoArg (writeIORef hi_diffs NormalHiDiffs) )
1626 , ( "no-hi-diffs" , NoArg (writeIORef hi_diffs NoHiDiffs) )
1627 , ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
1628 , ( "keep-hi-diffs" , NoArg (writeIORef keep_hi_diffs True) )
1629 --"hi-with-*" -> hiw <- readIORef hi_with (ToDo)
1631 --------- Profiling --------------------------------------------------
1632 , ( "auto-dicts" , NoArg (add opt_C "-fauto-sccs-on-dicts") )
1633 , ( "auto-all" , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") )
1634 , ( "auto" , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") )
1635 , ( "caf-all" , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") )
1636 -- "ignore-sccs" doesn't work (ToDo)
1638 ------- Miscellaneous -----------------------------------------------
1639 , ( "cpp" , NoArg (writeIORef cpp_flag True) )
1640 , ( "#include" , SepArg (add cmdline_hc_includes) )
1642 ------- Output Redirection ------------------------------------------
1643 , ( "odir" , HasArg (writeIORef output_dir . Just) )
1644 , ( "o" , SepArg (writeIORef output_file . Just) )
1645 , ( "osuf" , HasArg (writeIORef output_suf . Just) )
1646 , ( "hisuf" , HasArg (writeIORef hi_suf) )
1647 , ( "tmpdir" , HasArg (writeIORef tmp_prefix . (++ "/")) )
1648 , ( "ohi" , HasArg (\s -> case s of
1649 "-" -> writeIORef hi_on_stdout True
1650 _ -> writeIORef output_hi (Just s)) )
1653 , ( "keep-hc-file" , AnySuffix (\_ -> writeIORef keep_hc_files True) )
1654 , ( "keep-s-file" , AnySuffix (\_ -> writeIORef keep_s_files True) )
1655 , ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files True) )
1657 , ( "split-objs" , NoArg (if can_split
1658 then do writeIORef split_object_files True
1659 writeIORef hsc_lang HscC
1660 add opt_C "-fglobalise-toplev-names"
1661 add opt_c "-DUSE_SPLIT_MARKERS"
1662 else hPutStrLn stderr
1663 "warning: don't know how to split \
1664 \object files on this architecture"
1667 ------- Include/Import Paths ----------------------------------------
1668 , ( "i" , OptPrefix augment_import_paths )
1669 , ( "I" , Prefix augment_include_paths )
1671 ------- Libraries ---------------------------------------------------
1672 , ( "L" , Prefix augment_library_paths )
1673 , ( "l" , Prefix (add cmdline_libraries) )
1675 ------- Packages ----------------------------------------------------
1676 , ( "package-name" , HasArg (\s -> add opt_C ("-inpackage="++s)) )
1678 , ( "package" , HasArg (addPackage) )
1679 , ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
1681 ------- Specific phases --------------------------------------------
1682 , ( "pgmdep" , HasArg (writeIORef pgm_dep) )
1683 , ( "pgmL" , HasArg (writeIORef pgm_L) )
1684 , ( "pgmP" , HasArg (writeIORef pgm_P) )
1685 , ( "pgmC" , HasArg (writeIORef pgm_C) )
1686 , ( "pgmc" , HasArg (writeIORef pgm_c) )
1687 , ( "pgmm" , HasArg (writeIORef pgm_m) )
1688 , ( "pgms" , HasArg (writeIORef pgm_s) )
1689 , ( "pgma" , HasArg (writeIORef pgm_a) )
1690 , ( "pgml" , HasArg (writeIORef pgm_l) )
1692 , ( "optdep" , HasArg (add opt_dep) )
1693 , ( "optL" , HasArg (add opt_L) )
1694 , ( "optP" , HasArg (add opt_P) )
1695 , ( "optC" , HasArg (add opt_C) )
1696 , ( "optCrts" , HasArg (add opt_Crts) )
1697 , ( "optc" , HasArg (add opt_c) )
1698 , ( "optm" , HasArg (add opt_m) )
1699 , ( "opta" , HasArg (add opt_a) )
1700 , ( "optl" , HasArg (add opt_l) )
1701 , ( "optdll" , HasArg (add opt_dll) )
1703 ------ HsCpp opts ---------------------------------------------------
1704 , ( "D" , Prefix (\s -> add opt_P ("-D'"++s++"'") ) )
1705 , ( "U" , Prefix (\s -> add opt_P ("-U'"++s++"'") ) )
1707 ------ Warning opts -------------------------------------------------
1708 , ( "W" , NoArg (writeIORef warning_opt W_))
1709 , ( "Wall" , NoArg (writeIORef warning_opt W_all))
1710 , ( "Wnot" , NoArg (writeIORef warning_opt W_not))
1711 , ( "w" , NoArg (writeIORef warning_opt W_not))
1713 ----- Linker --------------------------------------------------------
1714 , ( "static" , NoArg (writeIORef static True) )
1716 ------ Compiler RTS options -----------------------------------------
1717 , ( "H" , HasArg (sizeOpt specific_heap_size) )
1718 , ( "K" , HasArg (sizeOpt specific_stack_size) )
1719 , ( "Rscale-sizes" , HasArg (floatOpt scale_sizes_by) )
1720 , ( "Rghc-timing" , NoArg (writeIORef collect_ghc_timing True) )
1722 ------ Debugging ----------------------------------------------------
1723 , ( "dstg-stats" , NoArg (writeIORef opt_StgStats True) )
1725 , ( "dno-" , Prefix (\s -> add anti_opt_C ("-d"++s)) )
1726 , ( "d" , AnySuffix (add opt_C) )
1728 ------ Machine dependant (-m<blah>) stuff ---------------------------
1730 , ( "monly-2-regs", NoArg (writeIORef stolen_x86_regs 2) )
1731 , ( "monly-3-regs", NoArg (writeIORef stolen_x86_regs 3) )
1732 , ( "monly-4-regs", NoArg (writeIORef stolen_x86_regs 4) )
1734 ------ Compiler flags -----------------------------------------------
1735 , ( "O2-for-C" , NoArg (writeIORef opt_minus_o2_for_C True) )
1736 , ( "O" , OptPrefix (setOptLevel) )
1738 , ( "fglasgow-exts-no-lang", NoArg ( do add opt_C "-fglasgow-exts") )
1740 , ( "fglasgow-exts" , NoArg (do add opt_C "-fglasgow-exts"
1743 , ( "fasm" , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
1745 , ( "fvia-C" , NoArg (writeIORef hsc_lang HscC) )
1747 , ( "fno-asm-mangling" , NoArg (writeIORef do_asm_mangling True) )
1749 , ( "fmax-simplifier-iterations",
1750 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
1752 , ( "fusagesp", NoArg (do writeIORef opt_UsageSPInf True
1753 add opt_C "-fusagesp-on") )
1755 -- flags that are "active negatives"
1756 , ( "fno-implicit-prelude" , PassFlag (add opt_C) )
1757 , ( "fno-prune-tydecls" , PassFlag (add opt_C) )
1758 , ( "fno-prune-instdecls" , PassFlag (add opt_C) )
1759 , ( "fno-pre-inlining" , PassFlag (add opt_C) )
1761 -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
1762 , ( "fno-", Prefix (\s -> add anti_opt_C ("-f"++s)) )
1764 -- Pass all remaining "-f<blah>" options to hsc
1765 , ( "f", AnySuffix (add opt_C) )
1768 -----------------------------------------------------------------------------
1769 -- Process command-line
1771 processArgs :: [String] -> [String] -> IO [String] -- returns spare args
1772 processArgs [] spare = return (reverse spare)
1773 processArgs args@(('-':_):_) spare = do
1774 args' <- processOneArg args
1775 processArgs args' spare
1776 processArgs (arg:args) spare =
1777 processArgs args (arg:spare)
1779 processOneArg :: [String] -> IO [String]
1780 processOneArg (('-':arg):args) = do
1781 let (rest,action) = findArg arg
1787 then io >> return args
1788 else throwDyn (UnknownFlag dash_arg)
1792 then fio rest >> return args
1794 [] -> throwDyn (UnknownFlag dash_arg)
1795 (arg1:args1) -> fio arg1 >> return args1
1799 [] -> throwDyn (UnknownFlag dash_arg)
1800 (arg1:args1) -> fio arg1 >> return args1
1804 then fio rest >> return args
1805 else throwDyn (UnknownFlag dash_arg)
1807 OptPrefix fio -> fio rest >> return args
1809 AnySuffix fio -> fio ('-':arg) >> return args
1813 then throwDyn (UnknownFlag dash_arg)
1814 else fio ('-':arg) >> return args
1816 findArg :: String -> (String,OptKind)
1818 = case [ (rest,k) | (pat,k) <- opts,
1819 Just rest <- [my_prefix_match pat arg],
1820 is_prefix k || null rest ] of
1821 [] -> throwDyn (UnknownFlag ('-':arg))
1824 is_prefix (NoArg _) = False
1825 is_prefix (SepArg _) = False
1826 is_prefix (PassFlag _) = False
1829 -----------------------------------------------------------------------------
1830 -- convert sizes like "3.5M" into integers
1832 sizeOpt :: IORef Integer -> String -> IO ()
1834 | c == "" = writeSizeOpt ref (truncate n)
1835 | c == "K" || c == "k" = writeSizeOpt ref (truncate (n * 1000))
1836 | c == "M" || c == "m" = writeSizeOpt ref (truncate (n * 1000 * 1000))
1837 | c == "G" || c == "g" = writeSizeOpt ref (truncate (n * 1000 * 1000 * 1000))
1838 | otherwise = throwDyn (UnknownFlag str)
1839 where (m, c) = span pred str
1840 n = read m :: Double
1841 pred c = isDigit c || c == '.'
1843 writeSizeOpt :: IORef Integer -> Integer -> IO ()
1844 writeSizeOpt ref new = do
1845 current <- readIORef ref
1847 then writeIORef ref new
1850 floatOpt :: IORef Double -> String -> IO ()
1852 = writeIORef ref (read str :: Double)
1854 -----------------------------------------------------------------------------
1855 -- Finding files in the installation
1857 GLOBAL_VAR(topDir, _libdir, String)
1859 -- grab the last -B option on the command line, and
1860 -- set topDir to its value.
1861 setTopDir :: [String] -> IO [String]
1863 let (minusbs, others) = partition (prefixMatch "-B") args
1865 [] -> writeIORef topDir _libdir
1866 some -> writeIORef topDir (drop 2 (last some)))
1869 findFile name alt_path = unsafePerformIO (do
1870 top_dir <- readIORef topDir
1871 let installed_file = top_dir ++ '/':name
1872 let inplace_file = top_dir ++ '/':_CURRENT_DIR ++ '/':alt_path
1873 b <- fileExist inplace_file
1874 if b then return inplace_file
1875 else return installed_file
1878 -----------------------------------------------------------------------------
1881 my_partition :: (a -> Maybe b) -> [a] -> ([b],[a])
1882 my_partition p [] = ([],[])
1883 my_partition p (a:as)
1884 = let (bs,cs) = my_partition p as in
1886 Nothing -> (bs,a:cs)
1889 my_prefix_match :: String -> String -> Maybe String
1890 my_prefix_match [] rest = Just rest
1891 my_prefix_match (p:pat) [] = Nothing
1892 my_prefix_match (p:pat) (r:rest)
1893 | p == r = my_prefix_match pat rest
1894 | otherwise = Nothing
1896 prefixMatch :: Eq a => [a] -> [a] -> Bool
1897 prefixMatch [] str = True
1898 prefixMatch pat [] = False
1899 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
1902 postfixMatch :: String -> String -> Bool
1903 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
1905 later = flip finally
1907 on b io = if b then io >> return (error "on") else return (error "on")
1909 my_catch = flip catchAllIO
1910 my_catchDyn = flip catchDyn
1912 global :: a -> IORef a
1913 global a = unsafePerformIO (newIORef a)
1915 split_filename :: String -> (String,String)
1916 split_filename f = (reverse rev_basename, reverse rev_ext)
1917 where (rev_ext, '.':rev_basename) = span ('.' /=) (reverse f)
1919 split :: Char -> String -> [String]
1920 split c s = case rest of
1922 _:rest -> chunk : split c rest
1923 where (chunk, rest) = break (==c) s
1925 add :: IORef [a] -> a -> IO ()
1928 writeIORef var (x:xs)
1930 remove_suffix :: String -> Char -> String
1932 | null pre = reverse suf
1933 | otherwise = reverse pre
1934 where (suf,pre) = break (==c) (reverse s)
1936 drop_longest_prefix :: String -> Char -> String
1937 drop_longest_prefix s c = reverse suf
1938 where (suf,pre) = break (==c) (reverse s)
1940 take_longest_prefix :: String -> Char -> String
1941 take_longest_prefix s c = reverse pre
1942 where (suf,pre) = break (==c) (reverse s)
1944 newsuf :: String -> String -> String
1945 newsuf suf s = remove_suffix s '.' ++ suf
1947 newdir :: String -> String -> String
1948 newdir dir s = dir ++ '/':drop_longest_prefix s '/'