2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
7 #include "HsVersions.h"
10 #ifdef __GLASGOW_HASKELL__
21 import AbsPrel ( builtinNameInfo )
23 import AbsUniType ( isDataTyCon, TauType(..), UniType, TyVar, TyCon, Class )
24 import Bag ( emptyBag, isEmptyBag, Bag )
25 import CE ( CE(..), UniqFM )
26 import CodeGen ( codeGen )
27 import CoreToStg ( topCoreBindsToStg )
28 import Desugar ( deSugar )
29 import DsMonad ( DsMatchContext, DsMatchKind, pprDsWarnings )
30 import E ( getE_TCE, E, GVE(..) )
31 -- most of above needed by mkInterface
33 import Errors ( pprBagOfErrors, Error(..) )
35 import Errors ( pprBagOfErrors, pprPodizedWarning, Error(..) )
36 #endif {- Data Parallel Haskell -}
37 import Id ( mkInstId, Id, Inst )
38 import Maybes ( maybeToBool, Maybe(..), MaybeErr(..) )
39 import MkIface ( mkInterface )
41 import PlainCore ( CoreExpr, CoreBinding, pprPlainCoreBinding,
42 PlainCoreProgram(..), PlainCoreBinding(..)
44 import Pretty ( PprStyle(..), ppShow, ppAboves, ppAppendFile
45 IF_ATTACK_PRAGMAS(COMMA ppAbove)
48 import ReadPrefix2 ( rdModule )
50 import {-hide from mkdependHS-}
51 ReadPrefix ( rdModule )
53 import Rename -- renameModule ...
54 import SimplCore -- core2core
55 import SimplStg ( stg2stg )
56 --ANDY: import SimplHaskell
57 import StgSyn ( pprPlainStgBinding, StgBinding, StgRhs, CostCentre,
58 StgBinderInfo, PlainStgProgram(..), PlainStgBinding(..)
60 import TCE ( rngTCE, {- UNUSED: printTypeInfoForPop,-} TCE(..)
61 IF_ATTACK_PRAGMAS(COMMA eltsUFM)
63 import Typecheck -- typecheckModule ...
65 import Unique -- lots of UniqueSupplies, etc.
68 #if ! OMIT_NATIVE_CODEGEN
69 import AsmCodeGen ( dumpRealAsm
70 # if __GLASGOW_HASKELL__
76 #ifdef USE_SEMANTIQUE_STRANAL
77 import ProgEnv ( ProgEnv(..), TreeProgEnv(..), createProgEnv )
78 import StrAnal ( ppShowStrAnal, OAT )
81 import PodizeCore ( podizeCore , PodWarning)
82 import AbsCTopApal ( nuAbsCToApal )
83 import NextUsed ( pprTopNextUsedC, getTopLevelNexts, AbsCNextUsed,
84 TopAbsCNextUsed(..) , MagicId)
86 #endif {- Data Parallel Haskell -}
90 #ifndef __GLASGOW_HASKELL__
93 main = mainIOtoDialogue main_io
101 BSCC("rdInput") readMn stdin ESCC `thenMn` \ input_pgm ->
102 getArgsMn `thenMn` \ raw_cmd_line ->
103 classifyOpts raw_cmd_line `thenMn` \ cmd_line_info ->
105 doIt cmd_line_info input_pgm
110 doIt :: CmdLineInfo -> String -> MainIO ()
112 doIt (switch_lookup_fn, core_cmds, stg_cmds) input_pgm
114 doIt (switch_lookup_fn, core_cmds, podize_cmds, pcore_cmds, stg_cmds) input_pgm
115 #endif {- Data Parallel Haskell -}
117 -- Help functions and boring global variables (e.g., printing style)
118 -- are figured out first; the "business end" follows, in the
122 -- ****** help functions:
124 switch_is_on switch = switchIsOn switch_lookup_fn switch
125 -- essentially, converts SwBool answer to Bool
127 string_switch_is_on switch
128 = maybeToBool (stringSwitchSet switch_lookup_fn switch)
130 doOutput switch io_action
132 case (stringSwitchSet switch_lookup_fn switch) of
133 Nothing -> returnMn ()
135 fopen fname "a+" `thenMn` \ file ->
136 if (file == ``NULL'') then
137 error ("doOutput: failed to open:"++fname)
139 io_action file `thenMn` \ () ->
140 fclose file `thenMn` \ status ->
143 else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
146 doDump switch hdr string
148 if (switch_is_on switch)
149 then writeMn stderr hdr `thenMn_`
150 writeMn stderr ('\n': string) `thenMn_`
155 -- ****** printing styles and column width:
157 pprCols = (80 :: Int) -- could make configurable
159 (pprStyle, pprErrorsStyle)
160 = if switch_is_on PprStyle_All then
161 (PprShowAll, PprShowAll)
162 else if switch_is_on PprStyle_Debug then
164 else if switch_is_on PprStyle_User then
165 (PprForUser, PprForUser)
167 (PprDebug, PprForUser)
169 pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
171 -- non-tuple-ish bindings...
173 -- ****** possibly fiddle builtin namespaces:
175 BIND (BSCC("builtinEnv")
176 builtinNameInfo switch_is_on {-switch looker-upper-}
179 _TO_ (init_val_lookup_fn, init_tc_lookup_fn) ->
181 -- **********************************************
182 -- Welcome to the business end of the main module
183 -- of the Glorious Glasgow Haskell compiler!
184 -- **********************************************
186 doDump Verbose "Glasgow Haskell Compiler, version 0.27" "" `thenMn_`
188 doDump Verbose "Data Parallel Haskell Compiler, version 0.06 (Glasgow 0.27)" ""
190 #endif {- Data Parallel Haskell -}
193 #ifdef USE_NEW_READER
197 `thenMn` \ (mod_name, export_list_fns, absyn_tree) ->
199 BIND (\x -> x) _TO_ bar_foo ->
200 -- so BINDs and BENDs add up...
202 BIND BSCC("rdModule")
205 _TO_ (mod_name, export_list_fns, absyn_tree) ->
208 -- reader things used (much?) later
209 ds_mod_name = mod_name
210 if_mod_name = mod_name
211 co_mod_name = mod_name
212 st_mod_name = mod_name
213 cc_mod_name = mod_name
214 -- also: export_list_fns
216 doDump D_dump_rif2hs "Parsed, Haskellised:"
217 (pp_show (ppr pprStyle absyn_tree)) `thenMn_`
219 -- UniqueSupplies for later use
220 getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer
221 getSplitUniqSupplyMn 't' `thenMn` \ tc_uniqs -> -- typechecker
222 getSplitUniqSupplyMn 'd' `thenMn` \ ds_uniqs -> -- desugarer
223 getSplitUniqSupplyMn 's' `thenMn` \ sm_uniqs -> -- core-to-core simplifier
224 getSplitUniqSupplyMn 'C' `thenMn` \ c2s_uniqs -> -- core-to-stg
225 getSplitUniqSupplyMn 'T' `thenMn` \ st_uniqs -> -- stg-to-stg passes
226 getSplitUniqSupplyMn 'F' `thenMn` \ fl_uniqs -> -- absC flattener
227 getSplitUniqSupplyMn 'P' `thenMn` \ prof_uniqs -> -- profiling tidy-upper
228 getSplitUniqSupplyMn 'L' `thenMn` \ pre_ncg_uniqs -> -- native-code generator
230 ncg_uniqs = {-mkUniqueSupplyGrimily-} pre_ncg_uniqs
234 renameModule switch_is_on
235 (init_val_lookup_fn, init_tc_lookup_fn)
239 _TO_ (mod4, import_names, final_name_funs, rn_errs_bag) ->
241 -- renamer things used (much?) later
242 cc_import_names = import_names
245 doDump D_dump_rn4 "Renamer-pass4:"
246 (pp_show (ppr pprStyle mod4)) `thenMn_`
248 if (not (isEmptyBag rn_errs_bag)) then
250 writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
251 `thenMn_` writeMn stderr "\n"
254 else -- No renaming errors, carry on with...
256 -- ******* TYPECHECKER
257 BIND (case BSCC("TypeChecker")
258 typecheckModule switch_is_on tc_uniqs final_name_funs mod4
265 panic "main: tickled tc_results even though there were errors"))
267 _TO_ (tc_errs_bag, tc_results) ->
270 ppr_b :: (Inst, TypecheckedExpr) -> Pretty
271 ppr_b (i,e) = ppr pprStyle (VarMonoBind (mkInstId i) e)
273 if (not (isEmptyBag tc_errs_bag)) then
274 -- Must stop *before* trying to dump tc output, because
275 -- if it fails it does not give you any useful stuff back!
276 writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
277 `thenMn_` writeMn stderr "\n"
280 else ( -- No typechecking errors either -- so, go for broke!
283 _TO_ (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
284 interface_stuff@(_,_,_,_,_), -- @-pat just for strictness...
285 tycon_specs, {-UNUSED:big_env,-} this_mod_env, ddump_deriv) ->
287 -- big_tce = getE_TCE big_env
288 -- big_elts = rngTCE big_tce
290 this_mod_tce = getE_TCE this_mod_env
291 this_mod_elts = rngTCE this_mod_tce
293 local_tycons = [tc | tc <- this_mod_elts,
294 isLocallyDefined tc, -- from this module only
295 isDataTyCon tc ] -- algebraic types only
297 -- pprTrace "Envs:" (ppAboves [
298 -- ppr pprStyle if_global_ids,
299 -- ppr pprStyle if_tce,
300 -- ppr pprStyle if_ce,
301 -- ppr pprStyle this_mod_env,
302 -- ppr pprStyle big_env
305 doDump D_dump_tc "Typechecked:"
307 (ppAboves [ppr pprStyle class_binds,
308 ppr pprStyle inst_binds,
309 ppAboves (map ppr_b const_binds),
310 ppr pprStyle val_binds])) `thenMn_`
312 doDump D_dump_deriv "Derived instances:"
313 (pp_show (ddump_deriv pprStyle)) `thenMn_`
316 -- doDump D_dump_type_info "" (pp_show (printTypeInfoForPop big_tce)) `thenMn_`
319 (desugared,ds_warnings)
321 deSugar ds_uniqs switch_lookup_fn ds_mod_name typechecked_quad
324 (if isEmptyBag ds_warnings then
327 writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings))
328 `thenMn_` writeMn stderr "\n"
331 doDump D_dump_ds "Desugared:" (pp_show (ppAboves
332 (map (pprPlainCoreBinding pprStyle) desugared))) `thenMn_`
334 -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
335 core2core core_cmds switch_lookup_fn co_mod_name pprStyle
336 sm_uniqs local_tycons tycon_specs desugared
337 `thenMn` \ (simplified, inlinings_env,
338 SpecData _ _ _ gen_tycons all_tycon_specs
339 spec_errs spec_warn spec_tyerrs) ->
341 doDump D_dump_simpl "Simplified:" (pp_show (ppAboves
342 (map (pprPlainCoreBinding pprStyle) simplified))) `thenMn_`
345 -- doDump D_dump_core_passes_info "(Haskell) Simplified:"
346 -- (coreToHaskell simplified) `thenMn_`
349 -- ******* PODIZE (VECTORIZE) THE CORE PROGRAM
351 (warn,podized) = BSCC("PodizeCore")
352 podizeCore podize_cmds switch_is_on
353 uniqSupply_p simplified
356 (if (not (null warn))
357 then writeMn stderr "\n" `thenMn_`
358 writeMn stderr (ppShow pprCols (ppAboves
359 (map (\w -> pprPodizedWarning w pprErrorsStyle) warn))) `thenMn_`
361 else returnMn ()) `thenMn_`
363 doDump D_dump_pod "Podization:" (pp_show (ppAboves
364 (map (pprPlainCoreBinding pprStyle) podized))) `thenMn_`
366 -- ******** CORE-TO-CORE SIMPLIFICATION OF PODIZED PROGRAM
368 psimplified = BSCC("PodizeCore2Core")
369 core2core pcore_cmds switch_is_on pprStyle
373 doDump D_dump_psimpl "Par Simplified:" (pp_show (ppAboves
374 (map (pprPlainCoreBinding pprStyle) psimplified))) `thenMn_`
376 #endif {- Data Parallel Haskell -}
378 #ifdef USE_SEMANTIQUE_STRANAL
379 -- ******* SEMANTIQUE STRICTNESS ANALYSER
380 doDump D_dump_stranal_sem "Strictness:" (ppShowStrAnal simplified big_env) `thenMn_`
383 -- ******* STG-TO-STG SIMPLIFICATION
386 stg_binds = BSCC("Core2Stg")
387 topCoreBindsToStg c2s_uniqs simplified
390 stg_binds = BSCC("Core2Stg")
391 topCoreBindsToStg c2s_uniqs psimplified
393 #endif {- Data Parallel Haskell -}
396 stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
397 `thenMn` \ (stg_binds2, cost_centre_info) ->
399 doDump D_dump_stg "STG syntax:" (pp_show (ppAboves
400 (map (pprPlainStgBinding pprStyle) stg_binds2))) `thenMn_`
402 -- ******* INTERFACE GENERATION (needs STG output)
404 mod_name = "_TestName_"
405 export_list_fns = (\ x -> False, \ x -> False)
406 inlinings_env = nullIdEnv
411 if_inst_info = emptyBag
415 = BSCC("MkInterface")
416 mkInterface switch_is_on if_mod_name export_list_fns
417 inlinings_env all_tycon_specs
422 doOutput ProduceHi BSCC("PrintInterface")
424 ppAppendFile file 1000{-pprCols-} mod_interface )
427 -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
429 abstractC = BSCC("CodeGen")
430 codeGen cc_mod_name -- module name for CC labelling
432 cc_import_names -- import names for CC registering
434 gen_tycons -- type constructors generated locally
435 all_tycon_specs -- tycon specialisations
439 flat_abstractC = BSCC("FlattenAbsC")
440 flattenAbsC fl_uniqs abstractC
443 doDump D_dump_absC "Abstract C:" (dumpRealC switch_is_on abstractC) `thenMn_`
445 doDump D_dump_flatC "Flat Abstract C:" (dumpRealC switch_is_on flat_abstractC) `thenMn_`
447 -- You can have C (c_output) or assembly-language (ncg_output),
448 -- but not both. [Allowing for both gives a space leak on
449 -- flat_abstractC. WDP 94/10]
451 (flat_absC_c, flat_absC_ncg) =
452 case (string_switch_is_on ProduceC || switch_is_on D_dump_realC,
453 string_switch_is_on ProduceS || switch_is_on D_dump_asm) of
454 (True, False) -> (flat_abstractC, AbsCNop)
455 (False, True) -> (AbsCNop, flat_abstractC)
456 (False, False) -> (AbsCNop, AbsCNop)
457 (True, True) -> error "ERROR: Can't do both .hc and .s at the same time"
459 c_output_d = BSCC("PrintRealC")
460 dumpRealC switch_is_on flat_absC_c
463 #ifdef __GLASGOW_HASKELL__
464 c_output_w = BSCC("PrintRealC")
465 (\ f -> writeRealC switch_is_on f flat_absC_c)
468 c_output_w = c_output_d
471 #if OMIT_NATIVE_CODEGEN
473 = error "*** GHC not built with a native-code generator ***"
474 ncg_output_w = ncg_output_d
476 ncg_output_d = BSCC("nativeCode")
477 dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
480 #ifdef __GLASGOW_HASKELL__
481 ncg_output_w = BSCC("nativeCode")
482 (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
485 ncg_output_w = ncg_output_d
489 doDump D_dump_asm "" ncg_output_d `thenMn_`
490 doOutput ProduceS ncg_output_w `thenMn_`
493 -- ********* GHC Finished !!!!
494 doDump D_dump_realC "" c_output_d `thenMn_`
495 doOutput ProduceC c_output_w `thenMn_`
498 -- ********* DPH needs native code generator, nearly finished.....
500 next_used_flatC = getTopLevelNexts flat_abstractC []
501 apal_module = nuAbsCToApal uniqSupply_L mod_name next_used_flatC
503 doDump D_dump_nextC "Next Used annotated C:" (ppShow pprCols
504 (pprTopNextUsedC next_used_flatC)) `thenMn_`
505 doOutput ProduceC ("! /* DAP assembler (APAL): */\n"++apal_module) `thenMn_`
507 #endif {- Data Parallel Haskell -}
509 {-)-} BEND ) BEND BEND BEND BEND