SCM Repository
Annotation of /sml/trunk/src/compiler/FLINT/main/flintcomp.sml
Parent Directory
| 
Revision Log
Revision 102 - (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 : | monnier | 102 | structure Closure = Closure(MachSpec) |
| 15 : | monnier | 16 | 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 : | monnier | 102 | val litsplit = phase "Compiler 075 litsplit" Literals.litsplit |
| 37 : | val lit2cps = phase "Compiler 076 lit2cps" Literals.lit2cps | ||
| 38 : | val closure = phase "Compiler 080 closure" Closure.closeCPS | ||
| 39 : | monnier | 16 | val globalfix = phase "Compiler 090 globalfix" GlobalFix.globalfix |
| 40 : | val spill = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize | ||
| 41 : | then phase "Compiler 100 spill" Spill.spill | ||
| 42 : | else fn x => x | ||
| 43 : | val limit = phase "Compiler 110 limit" Limit.nolimit | ||
| 44 : | val codegen = phase "Compiler 120 cpsgen" Gen.codegen | ||
| 45 : | |||
| 46 : | monnier | 102 | val closureD = phase "Compiler 081 closureD" Closure.closeCPS |
| 47 : | val globalfixD= phase "Compiler 091 globalfixD" GlobalFix.globalfix | ||
| 48 : | val spillD = if MachSpec.spillAreaSz < 500 * MachSpec.valueSize | ||
| 49 : | then phase "Compiler 101 spillD" Spill.spill | ||
| 50 : | else fn x => x | ||
| 51 : | val limitD = phase "Compiler 110 limitD" Limit.nolimit | ||
| 52 : | val codegenD = phase "Compiler 121 cpsgenD" Gen.codegen | ||
| 53 : | monnier | 16 | |
| 54 : | monnier | 71 | (** pretty printing for the FLINT and CPS code *) |
| 55 : | val (prF, prC) = | ||
| 56 : | let fun prGen (flag,printE) s e = | ||
| 57 : | monnier | 102 | if !flag then (say ("\n[After " ^ s ^ " ...]\n\n"); printE e; |
| 58 : | say "\n"; e) | ||
| 59 : | monnier | 71 | else e |
| 60 : | in (prGen (CGC.printFlint, PPFlint.printProg), | ||
| 61 : | prGen (CGC.printit, PPCps.printcps0)) | ||
| 62 : | end | ||
| 63 : | monnier | 16 | |
| 64 : | monnier | 71 | (** writing out a term into a error output file *) |
| 65 : | fun dumpTerm (printE, s, le) = | ||
| 66 : | let val outS = TextIO.openAppend s; | ||
| 67 : | val saveOut = !Control.Print.out | ||
| 68 : | fun done () = | ||
| 69 : | (TextIO.closeOut outS; Control.Print.out := saveOut) | ||
| 70 : | in Control.Print.out := {say = fn s => TextIO.output(outS,s), | ||
| 71 : | flush = fn () => TextIO.flushOut outS}; | ||
| 72 : | printE le handle x => (done () handle _ => (); raise x); | ||
| 73 : | done () | ||
| 74 : | end (* function dumpTerm *) | ||
| 75 : | |||
| 76 : | monnier | 16 | (** compiling FLINT code into the binary machine code *) |
| 77 : | fun flintcomp(flint, compInfo as {error, sourceName=src, ...}: CB.compInfo) = | ||
| 78 : | let fun err severity s = | ||
| 79 : | error (0,0) severity (concat["Real constant out of range: ",s,"\n"]) | ||
| 80 : | |||
| 81 : | fun check (checkE,printE,chkId) (enableChk,lvl,logId) e = | ||
| 82 : | (if !enableChk andalso checkE (e,lvl) then | ||
| 83 : | monnier | 71 | (dumpTerm (printE, src ^ "." ^ chkId ^ logId, e); |
| 84 : | bug (chkId ^ " typing errors " ^ logId)) | ||
| 85 : | monnier | 16 | else (); |
| 86 : | e) | ||
| 87 : | monnier | 71 | fun chkF (b, s) = |
| 88 : | check (ChkFlint.checkTop, PPFlint.printFundec, | ||
| 89 : | "FLINT") (CGC.checkFlint, b, s) | ||
| 90 : | monnier | 16 | |
| 91 : | monnier | 102 | val _ = (chkF (false,"1") o prF "Translation/Normalization") flint |
| 92 : | monnier | 71 | val flint = (chkF (false,"2") o prF "Lcontract" o lcontract) flint |
| 93 : | monnier | 16 | val flint = |
| 94 : | if !CGC.specialize then | ||
| 95 : | monnier | 71 | (chkF (false,"3") o prF "Specialization" o specialize) flint |
| 96 : | monnier | 16 | else flint |
| 97 : | |||
| 98 : | monnier | 71 | val flint = (chkF (false, "4") o prF "Wrapping" o wrapping) flint |
| 99 : | val flint = (chkF (true, "5") o prF "Reify" o reify) flint | ||
| 100 : | monnier | 102 | |
| 101 : | val (nc0, ncn, dseg) = | ||
| 102 : | let val function = convert flint | ||
| 103 : | val _ = prC "convert" function | ||
| 104 : | monnier | 71 | val function = (prC "cpstrans" o cpstrans) function |
| 105 : | monnier | 102 | val function = |
| 106 : | if !CGC.cpsopt then cpsopt (function,NONE,false) | ||
| 107 : | else function | ||
| 108 : | monnier | 71 | val _ = prC "cpsopt" function |
| 109 : | monnier | 45 | |
| 110 : | monnier | 102 | val (function, dlit) = litsplit function |
| 111 : | val data = lit2cps dlit | ||
| 112 : | val _ = prC "cpsopt-code" function | ||
| 113 : | val _ = prC "cpsopt-data" data | ||
| 114 : | |||
| 115 : | monnier | 71 | fun gen fx = |
| 116 : | let val fx = (prC "closure" o closure) fx | ||
| 117 : | val carg = globalfix fx | ||
| 118 : | val carg = spill carg | ||
| 119 : | val (carg, limit) = limit carg | ||
| 120 : | in codegen (carg, limit, err); | ||
| 121 : | collect () | ||
| 122 : | end | ||
| 123 : | monnier | 102 | |
| 124 : | fun gdata dd = | ||
| 125 : | let val x = Control.CG.printit | ||
| 126 : | val y = !x | ||
| 127 : | val _ = (x := false) | ||
| 128 : | val fx = (prC "closure" o closureD) dd | ||
| 129 : | val carg = globalfixD fx | ||
| 130 : | val carg = spillD carg | ||
| 131 : | val (carg, limit) = limitD carg | ||
| 132 : | in codegenD (carg, limit, err); | ||
| 133 : | (collect ()) before (x := y) | ||
| 134 : | end | ||
| 135 : | monnier | 71 | in case CpsSplit.cpsSplit function |
| 136 : | monnier | 102 | of (fun0 :: funn) => (gen fun0, map gen funn, gdata data) |
| 137 : | monnier | 71 | | [] => bug "unexpected case on gen in flintcomp" |
| 138 : | end | ||
| 139 : | monnier | 102 | in {c0=nc0, cn=ncn, data=dseg, name=ref (SOME src)} |
| 140 : | monnier | 16 | end (* function flintcomp *) |
| 141 : | |||
| 142 : | monnier | 71 | val flintcomp = phase "Compiler 050 flintcomp" flintcomp |
| 143 : | monnier | 16 | |
| 144 : | end (* local *) | ||
| 145 : | end (* structure FLINTComp *) | ||
| 146 : | monnier | 95 | |
| 147 : | (* | ||
| 148 : | * $Log: flintcomp.sml,v $ | ||
| 149 : | * Revision 1.1.1.1 1998/04/08 18:39:40 george | ||
| 150 : | * Version 110.5 | ||
| 151 : | * | ||
| 152 : | *) |
| root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
| Powered by ViewVC 1.0.0 |
