SCM Repository
Annotation of /sml/trunk/src/cm/compile/generic.sml
Parent Directory
| 
Revision Log
Revision 326 - (view) (download)
| 1 : | blume | 295 | (* |
| 2 : | * The "generic" compilation traversal functor. | ||
| 3 : | blume | 314 | * (In fact, it is probably possible to use this for things other |
| 4 : | * than compilation as well.) | ||
| 5 : | blume | 295 | * |
| 6 : | * (C) 1999 Lucent Technologies, Bell Laboratories | ||
| 7 : | * | ||
| 8 : | * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp) | ||
| 9 : | *) | ||
| 10 : | local | ||
| 11 : | structure GP = GeneralParams | ||
| 12 : | blume | 294 | structure DG = DependencyGraph |
| 13 : | blume | 314 | structure GG = GroupGraph |
| 14 : | blume | 295 | in |
| 15 : | functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig | ||
| 16 : | blume | 294 | |
| 17 : | blume | 295 | type envdelta = CT.envdelta |
| 18 : | blume | 314 | type result = CT.result |
| 19 : | blume | 294 | |
| 20 : | blume | 299 | val bnode : GP.info -> DG.bnode -> envdelta option |
| 21 : | blume | 326 | val snode : GP.info -> DG.snode -> envdelta option |
| 22 : | blume | 314 | val group : GP.info -> GG.group -> result option |
| 23 : | blume | 294 | |
| 24 : | blume | 295 | end = struct |
| 25 : | blume | 294 | |
| 26 : | blume | 295 | type envdelta = CT.envdelta |
| 27 : | type env = CT.env | ||
| 28 : | type benv = CT.benv | ||
| 29 : | blume | 314 | type result = CT.result |
| 30 : | blume | 295 | |
| 31 : | blume | 314 | (* This is to prevent re-execution of dosml if the first one failed *) |
| 32 : | local | ||
| 33 : | val failures = ref SmlInfoSet.empty | ||
| 34 : | in | ||
| 35 : | fun dosml (i, e, gp) = | ||
| 36 : | if SmlInfoSet.member (!failures, i) then NONE | ||
| 37 : | else case CT.dosml (i, e, gp) of | ||
| 38 : | SOME r => SOME r | ||
| 39 : | | NONE => (failures := SmlInfoSet.add (!failures, i); NONE) | ||
| 40 : | fun clearFailures () = failures := SmlInfoSet.empty | ||
| 41 : | end | ||
| 42 : | |||
| 43 : | blume | 318 | (* To implement "keep_going" we have two different ways of |
| 44 : | * combining a "work" function with a "layer" function. | ||
| 45 : | * One way is to give up and do no further work once there | ||
| 46 : | * is a result of NONE, the other one is to continue | ||
| 47 : | * working (but to ignore the results of such work). *) | ||
| 48 : | fun layerwork (k, layer, work) (x, NONE) = | ||
| 49 : | (if k then ignore (work x) else (); NONE) | ||
| 50 : | | layerwork (k, layer, work) (x, SOME e) = | ||
| 51 : | case work x of | ||
| 52 : | NONE => NONE | ||
| 53 : | | SOME e' => SOME (layer (e', e)) | ||
| 54 : | blume | 295 | |
| 55 : | blume | 301 | fun bnode (gp: GP.info) n = let |
| 56 : | blume | 294 | |
| 57 : | blume | 318 | val k = #keep_going (#param gp) |
| 58 : | val glob = foldl (layerwork (k, CT.blayer, farbnode gp)) | ||
| 59 : | val loc = | ||
| 60 : | foldl (layerwork (k, CT.blayer, | ||
| 61 : | Option.map CT.bnofilter o bnode gp)) | ||
| 62 : | blume | 294 | |
| 63 : | blume | 299 | fun bn (DG.PNODE p) = SOME (CT.primitive gp p) |
| 64 : | blume | 295 | | bn (DG.BNODE n) = let |
| 65 : | val { bininfo, localimports = li, globalimports = gi } = n | ||
| 66 : | blume | 299 | fun mkenv () = loc (glob (SOME (CT.bpervasive gp)) gi) li |
| 67 : | blume | 295 | in |
| 68 : | blume | 298 | CT.dostable (bininfo, mkenv, gp) |
| 69 : | blume | 295 | end |
| 70 : | in | ||
| 71 : | blume | 301 | (* don't eta-reduce this -- it'll lead to an infinite loop! *) |
| 72 : | bn n | ||
| 73 : | blume | 295 | end |
| 74 : | blume | 294 | |
| 75 : | blume | 295 | and farbnode gp (f, n) = |
| 76 : | case (bnode gp n, f) of | ||
| 77 : | (NONE, _) => NONE | ||
| 78 : | | (SOME d, NONE) => SOME (CT.bnofilter d) | ||
| 79 : | | (SOME d, SOME s) => SOME (CT.bfilter (d, s)) | ||
| 80 : | |||
| 81 : | fun snode gp (DG.SNODE n) = let | ||
| 82 : | |||
| 83 : | blume | 318 | val k = #keep_going (#param gp) |
| 84 : | val glob = | ||
| 85 : | foldl (layerwork (k, CT.layer, farsbnode gp)) | ||
| 86 : | val loc = | ||
| 87 : | foldl (layerwork (k, CT.layer, | ||
| 88 : | Option.map CT.nofilter o snode gp)) | ||
| 89 : | blume | 295 | |
| 90 : | val { smlinfo, localimports = li, globalimports = gi } = n | ||
| 91 : | blume | 301 | val desc = SmlInfo.fullSpec smlinfo |
| 92 : | val pe = SOME (CT.pervasive gp) | ||
| 93 : | val ge = glob pe gi | ||
| 94 : | val e = loc ge li | ||
| 95 : | blume | 295 | in |
| 96 : | blume | 299 | case e of |
| 97 : | blume | 295 | NONE => NONE |
| 98 : | blume | 314 | | SOME e => dosml (smlinfo, e, gp) |
| 99 : | blume | 295 | end |
| 100 : | |||
| 101 : | and sbnode gp (DG.SB_BNODE b) = bnode gp b | ||
| 102 : | | sbnode gp (DG.SB_SNODE s) = snode gp s | ||
| 103 : | |||
| 104 : | and farsbnode gp (f, n) = | ||
| 105 : | case (sbnode gp n, f) of | ||
| 106 : | (NONE, _) => NONE | ||
| 107 : | | (SOME d, NONE) => SOME (CT.nofilter d) | ||
| 108 : | | (SOME d, SOME s) => SOME (CT.filter (d, s)) | ||
| 109 : | blume | 314 | |
| 110 : | fun impexp gp (n, _) = Option.map CT.env2result (farsbnode gp n) | ||
| 111 : | |||
| 112 : | blume | 318 | fun group gp (GG.GROUP { exports, ... }) = |
| 113 : | (foldl (layerwork (#keep_going (#param gp), | ||
| 114 : | CT.rlayer, | ||
| 115 : | impexp gp)) | ||
| 116 : | (SOME CT.empty) | ||
| 117 : | (SymbolMap.listItems exports)) | ||
| 118 : | blume | 314 | before clearFailures () |
| 119 : | blume | 295 | end |
| 120 : | blume | 294 | end |
| root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
| Powered by ViewVC 1.0.0 |
