Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/compile/generic.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/compile/generic.sml

Parent Directory Parent Directory | Revision Log 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