SCM Repository
Annotation of /sml/trunk/src/compiler/FLINT/main/flintcomp.sml
Parent Directory
| 
Revision Log
Revision 59 - (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 : | val lconLexp = phase "Compiler 052 lcontract" LContract.lcontract | ||
| 26 : | val specLexp = phase "Compiler 053 specLexp" Specialize.specialize | ||
| 27 : | val wrapLexp = phase "Compiler 054 wrapLexp" Wrapping.wrapLexp | ||
| 28 : | monnier | 45 | val wrapLexpN = phase "Compiler 054 wrapLexpN" WrappingNEW.wrapping |
| 29 : | monnier | 16 | val ltyComp = phase "Compiler 055 ltyComp" Reify.ltyComp |
| 30 : | monnier | 45 | val reify = phase "Compiler 055 ltyCompN" ReifyNEW.reify |
| 31 : | monnier | 16 | val narrow = phase "Compiler 056 ltNarrow" LtNarrow.narrow |
| 32 : | (* val lambdaopt = phase "Compiler 057 lambdaopt" LContract.lcontract *) | ||
| 33 : | |||
| 34 : | val convert = phase "Compiler 060 Convert" Convert.convert | ||
| 35 : | val cpstrans = phase "Compiler 065 CPStrans" CPStrans.cpstrans | ||
| 36 : | val cpsopt = phase "Compiler 070 cpsopt" CPSopt.reduce | ||
| 37 : | val closure = phase "Compiler 080 closure" NewClosure.closeCPS | ||
| 38 : | val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix | ||
| 39 : | val spill = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize | ||
| 40 : | then phase "Compiler 100 spill" Spill.spill | ||
| 41 : | else fn x => x | ||
| 42 : | val limit = phase "Compiler 110 limit" Limit.nolimit | ||
| 43 : | val codegen = phase "Compiler 120 cpsgen" Gen.codegen | ||
| 44 : | |||
| 45 : | fun prGen (flag,printE) s e = | ||
| 46 : | (if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else (); | ||
| 47 : | e) | ||
| 48 : | |||
| 49 : | val prLexp = prGen (CGC.printLambda, MCprint.printLexp) | ||
| 50 : | monnier | 51 | val prFlint = prGen (CGC.printFlint, PPFlint.printProg) |
| 51 : | monnier | 16 | val prCps = prGen (CGC.printit, PPCps.printcps0) |
| 52 : | |||
| 53 : | (** compiling FLINT code into the binary machine code *) | ||
| 54 : | fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) = | ||
| 55 : | let fun err severity s = | ||
| 56 : | error (0,0) severity (concat["Real constant out of range: ",s,"\n"]) | ||
| 57 : | |||
| 58 : | fun dumpTerm (printE, s, le) = | ||
| 59 : | let val outS = TextIO.openAppend (src ^ s); | ||
| 60 : | val saveOut = !Control.Print.out | ||
| 61 : | fun done () = | ||
| 62 : | (TextIO.closeOut outS; Control.Print.out := saveOut) | ||
| 63 : | in Control.Print.out := {say = fn s => TextIO.output(outS,s), | ||
| 64 : | flush = fn () => TextIO.flushOut outS}; | ||
| 65 : | printE le handle x => (done () handle _ => (); raise x); | ||
| 66 : | done () | ||
| 67 : | end | ||
| 68 : | league | 59 | |
| 69 : | (* checking for type errors in various phases. *) | ||
| 70 : | monnier | 16 | fun check (checkE,printE,chkId) (enableChk,lvl,logId) e = |
| 71 : | (if !enableChk andalso checkE (e,lvl) then | ||
| 72 : | league | 59 | (dumpTerm (printE, "." ^ chkId ^ logId, e) |
| 73 : | (* the following line will cause type errors to halt | ||
| 74 : | * compilation. i'd rather let it continue. --league | ||
| 75 : | *) | ||
| 76 : | (* bug (chkId ^ " typing errors " ^ logId) *) | ||
| 77 : | ) | ||
| 78 : | monnier | 16 | else (); |
| 79 : | e) | ||
| 80 : | val chkLexp = check (CheckLty.checkLty, MCprint.printLexp, "lambda") | ||
| 81 : | val chkFlint = check (ChkFlint.checkTop, PPFlint.printFundec, "FLINT") | ||
| 82 : | |||
| 83 : | league | 59 | val _ = (chkFlint (CGC.checkFlint,1,"1") o prFlint "Translation") flint |
| 84 : | monnier | 16 | |
| 85 : | val flint = | ||
| 86 : | league | 59 | (chkFlint (CGC.checkFlint,1,"2") o prFlint "Lcontract" o lconLexp) |
| 87 : | monnier | 16 | flint |
| 88 : | |||
| 89 : | val flint = | ||
| 90 : | if !CGC.specialize then | ||
| 91 : | league | 59 | (chkFlint (CGC.checkFlint,1,"3") |
| 92 : | monnier | 45 | o prFlint "Specialization" o specLexp) flint |
| 93 : | monnier | 16 | else flint |
| 94 : | |||
| 95 : | monnier | 45 | (* |
| 96 : | (*** explicit FLINT checking phase ***) | ||
| 97 : | val flint = chkFlint (ref true, 3, "3") flint | ||
| 98 : | |||
| 99 : | (*** check out the new wrapping function *) | ||
| 100 : | val nflint1 = (prFlint "NewWrapping" o wrapLexpN) flint | ||
| 101 : | val nflint2 = chkFlint (ref true, 4, "4") nflint1 | ||
| 102 : | val nflint3 = | ||
| 103 : | (chkFlint (ref false, 5, "5") o prFlint "NewReify" o reify) nflint2 | ||
| 104 : | val nlambda = Flint2Lambda.transFundec(nflint3) | ||
| 105 : | val nlambda = | ||
| 106 : | (chkLexp (CGC.checklty1,21,"4") o prLexp "NarrowingN" o narrow) nlambda | ||
| 107 : | val (nfunction,ntable) = convert nlambda | ||
| 108 : | *) | ||
| 109 : | |||
| 110 : | monnier | 16 | val lambda = |
| 111 : | (chkLexp (CGC.checklty1,1,"1") | ||
| 112 : | o prLexp "Translation-To-Lambda" | ||
| 113 : | o Flint2Lambda.transFundec) | ||
| 114 : | flint | ||
| 115 : | |||
| 116 : | val lambda = | ||
| 117 : | (chkLexp (CGC.checklty1,11,"2") o prLexp "Wrapping" o wrapLexp) | ||
| 118 : | lambda | ||
| 119 : | |||
| 120 : | val lambda = (chkLexp (CGC.checklty1,21,"3") o ltyComp) lambda | ||
| 121 : | |||
| 122 : | val lambda = | ||
| 123 : | (chkLexp (CGC.checklty1,21,"4") o prLexp "Narrowing" o narrow) lambda | ||
| 124 : | |||
| 125 : | (* | ||
| 126 : | val lambda = (chkLexp (CGC.checklty2,21,"5") o lambdaopt) lambda | ||
| 127 : | *) | ||
| 128 : | |||
| 129 : | val (function,table) = convert lambda | ||
| 130 : | monnier | 45 | local exception ZZZ |
| 131 : | in val table : FLINT.lty Intmap.intmap = Intmap.new(32, ZZZ) | ||
| 132 : | end | ||
| 133 : | monnier | 16 | val _ = prCps "convert" function |
| 134 : | |||
| 135 : | val function = (prCps "cpstrans" o cpstrans) function | ||
| 136 : | |||
| 137 : | val (function,table) = | ||
| 138 : | if !CGC.cpsopt then cpsopt (function,table,NONE,false) | ||
| 139 : | else (function,table) | ||
| 140 : | val _ = prCps "cpsopt" function | ||
| 141 : | |||
| 142 : | fun gen function = let | ||
| 143 : | val function = (prCps "closure" o closure) function | ||
| 144 : | val carg = globalfix function | ||
| 145 : | val carg = spill carg | ||
| 146 : | val (carg, limit) = limit carg | ||
| 147 : | in | ||
| 148 : | codegen (carg, limit, err); | ||
| 149 : | collect () | ||
| 150 : | end | ||
| 151 : | |||
| 152 : | val fun0 :: funn = CpsSplit.cpsSplit function | ||
| 153 : | val c0 = gen fun0 | ||
| 154 : | val cn = map gen funn | ||
| 155 : | |||
| 156 : | in {c0=c0, cn=cn , name=ref (SOME src)} | ||
| 157 : | end (* function flintcomp *) | ||
| 158 : | |||
| 159 : | val flintcomp = phase "Compiler 050 FLINTComp" flintcomp | ||
| 160 : | |||
| 161 : | end (* local *) | ||
| 162 : | end (* structure FLINTComp *) |
| root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
| Powered by ViewVC 1.0.0 |
