SCM Repository
Annotation of /sml/trunk/src/compiler/FLINT/main/flintcomp.sml
Parent Directory
|
Revision Log
Revision 95 - (view) (download)
1 : | monnier | 16 | (* COPYRIGHT (c) 1998 YALE FLINT PROJECT *) |
2 : | (* flintcomp.sml *) | ||
3 : | |||
4 : | functor FLINTComp (structure Gen: CPSGEN | ||
5 : | val collect: unit -> Word8Vector.vector) : CODEGENERATOR = | ||
6 : | struct | ||
7 : | |||
8 : | local structure CB = CompBasic | ||
9 : | structure CGC = Control.CG | ||
10 : | structure MachSpec = Gen.MachSpec | ||
11 : | structure Convert = Convert(MachSpec) | ||
12 : | structure CPStrans = CPStrans(MachSpec) | ||
13 : | structure CPSopt = CPSopt(MachSpec) | ||
14 : | structure NewClosure = NClosure(MachSpec) | ||
15 : | structure Spill = Spill(MachSpec) | ||
16 : | structure CpsSplit = CpsSplitFun (MachSpec) | ||
17 : | in | ||
18 : | |||
19 : | val architecture = Gen.MachSpec.architecture | ||
20 : | fun bug s = ErrorMsg.impossible ("FLINTComp:" ^ s) | ||
21 : | val say = Control.Print.say | ||
22 : | |||
23 : | fun phase x = Stats.doPhase (Stats.makePhase x) | ||
24 : | |||
25 : | monnier | 71 | val fcollect = phase "Compiler 052 collect" (fn le => (Collect.collect le; le)) |
26 : | monnier | 84 | (* val fcontract = phase "Compiler 052 fcontract" FContract.contract *) |
27 : | monnier | 71 | val lcontract = phase "Compiler 052 lcontract" LContract.lcontract |
28 : | val specialize= phase "Compiler 053 specialize" Specialize.specialize | ||
29 : | val wrapping = phase "Compiler 054 wrapping" Wrapping.wrapping | ||
30 : | val reify = phase "Compiler 055 reify" Reify.reify | ||
31 : | monnier | 16 | (* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *) |
32 : | |||
33 : | monnier | 71 | val convert = phase "Compiler 060 convert" Convert.convert |
34 : | val cpstrans = phase "Compiler 065 cpstrans" CPStrans.cpstrans | ||
35 : | monnier | 16 | val cpsopt = phase "Compiler 070 cpsopt" CPSopt.reduce |
36 : | val closure = phase "Compiler 080 closure" NewClosure.closeCPS | ||
37 : | val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix | ||
38 : | val spill = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize | ||
39 : | then phase "Compiler 100 spill" Spill.spill | ||
40 : | else fn x => x | ||
41 : | val limit = phase "Compiler 110 limit" Limit.nolimit | ||
42 : | val codegen = phase "Compiler 120 cpsgen" Gen.codegen | ||
43 : | |||
44 : | |||
45 : | monnier | 71 | (** pretty printing for the FLINT and CPS code *) |
46 : | val (prF, prC) = | ||
47 : | let fun prGen (flag,printE) s e = | ||
48 : | if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e; e) | ||
49 : | else e | ||
50 : | in (prGen (CGC.printFlint, PPFlint.printProg), | ||
51 : | prGen (CGC.printit, PPCps.printcps0)) | ||
52 : | end | ||
53 : | monnier | 16 | |
54 : | monnier | 71 | (** writing out a term into a error output file *) |
55 : | fun dumpTerm (printE, s, le) = | ||
56 : | let val outS = TextIO.openAppend s; | ||
57 : | val saveOut = !Control.Print.out | ||
58 : | fun done () = | ||
59 : | (TextIO.closeOut outS; Control.Print.out := saveOut) | ||
60 : | in Control.Print.out := {say = fn s => TextIO.output(outS,s), | ||
61 : | flush = fn () => TextIO.flushOut outS}; | ||
62 : | printE le handle x => (done () handle _ => (); raise x); | ||
63 : | done () | ||
64 : | end (* function dumpTerm *) | ||
65 : | |||
66 : | monnier | 16 | (** compiling FLINT code into the binary machine code *) |
67 : | fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) = | ||
68 : | let fun err severity s = | ||
69 : | error (0,0) severity (concat["Real constant out of range: ",s,"\n"]) | ||
70 : | |||
71 : | fun check (checkE,printE,chkId) (enableChk,lvl,logId) e = | ||
72 : | (if !enableChk andalso checkE (e,lvl) then | ||
73 : | monnier | 71 | (dumpTerm (printE, src ^ "." ^ chkId ^ logId, e); |
74 : | bug (chkId ^ " typing errors " ^ logId)) | ||
75 : | monnier | 16 | else (); |
76 : | e) | ||
77 : | monnier | 71 | fun chkF (b, s) = |
78 : | check (ChkFlint.checkTop, PPFlint.printFundec, | ||
79 : | "FLINT") (CGC.checkFlint, b, s) | ||
80 : | monnier | 16 | |
81 : | monnier | 71 | val _ = (chkF (false,"1") o prF "Translation") flint |
82 : | val flint = (chkF (false,"2") o prF "Lcontract" o lcontract) flint | ||
83 : | monnier | 16 | val flint = |
84 : | if !CGC.specialize then | ||
85 : | monnier | 71 | (chkF (false,"3") o prF "Specialization" o specialize) flint |
86 : | monnier | 16 | else flint |
87 : | |||
88 : | monnier | 71 | val flint = (chkF (false, "4") o prF "Wrapping" o wrapping) flint |
89 : | val flint = (chkF (true, "5") o prF "Reify" o reify) flint | ||
90 : | val function = convert flint | ||
91 : | val (nc0, ncn) = | ||
92 : | let val _ = prC "convert" function | ||
93 : | val function = (prC "cpstrans" o cpstrans) function | ||
94 : | local exception ZZZ | ||
95 : | in | ||
96 : | val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ) | ||
97 : | end | ||
98 : | val (function,table) = | ||
99 : | if !CGC.cpsopt then cpsopt (function,table,NONE,false) | ||
100 : | else (function,table) | ||
101 : | val _ = prC "cpsopt" function | ||
102 : | monnier | 45 | |
103 : | monnier | 71 | fun gen fx = |
104 : | let val fx = (prC "closure" o closure) fx | ||
105 : | val carg = globalfix fx | ||
106 : | val carg = spill carg | ||
107 : | val (carg, limit) = limit carg | ||
108 : | in codegen (carg, limit, err); | ||
109 : | collect () | ||
110 : | end | ||
111 : | in case CpsSplit.cpsSplit function | ||
112 : | of (fun0 :: funn) => (gen fun0, map gen funn) | ||
113 : | | [] => bug "unexpected case on gen in flintcomp" | ||
114 : | end | ||
115 : | in {c0=nc0, cn=ncn , name=ref (SOME src)} | ||
116 : | monnier | 16 | end (* function flintcomp *) |
117 : | |||
118 : | monnier | 71 | val flintcomp = phase "Compiler 050 flintcomp" flintcomp |
119 : | monnier | 16 | |
120 : | end (* local *) | ||
121 : | end (* structure FLINTComp *) | ||
122 : | monnier | 95 | |
123 : | (* | ||
124 : | * $Log: flintcomp.sml,v $ | ||
125 : | * Revision 1.1.1.1 1998/04/08 18:39:40 george | ||
126 : | * Version 110.5 | ||
127 : | * | ||
128 : | *) |
root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
Powered by ViewVC 1.0.0 |