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 369 - (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 : blume 369 functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> TRAVERSAL
16 :     where type envdelta = CT.envdelta
17 :     and type result = CT.result =
18 :     struct
19 : blume 294
20 : blume 295 type envdelta = CT.envdelta
21 :     type env = CT.env
22 :     type benv = CT.benv
23 : blume 314 type result = CT.result
24 : blume 295
25 : blume 351 val smlcache = ref (SmlInfoMap.empty: envdelta option SmlInfoMap.map)
26 :     val stablecache = ref (StableMap.empty: envdelta option StableMap.map)
27 : blume 369 fun reset () = (CT.nestedTraversalReset ();
28 :     smlcache := SmlInfoMap.empty)
29 : blume 351 fun resetAll () = (reset (); stablecache := StableMap.empty)
30 : blume 314
31 : blume 318 (* To implement "keep_going" we have two different ways of
32 :     * combining a "work" function with a "layer" function.
33 :     * One way is to give up and do no further work once there
34 :     * is a result of NONE, the other one is to continue
35 :     * working (but to ignore the results of such work). *)
36 :     fun layerwork (k, layer, work) (x, NONE) =
37 :     (if k then ignore (work x) else (); NONE)
38 :     | layerwork (k, layer, work) (x, SOME e) =
39 :     case work x of
40 :     NONE => NONE
41 :     | SOME e' => SOME (layer (e', e))
42 : blume 295
43 : blume 301 fun bnode (gp: GP.info) n = let
44 : blume 294
45 : blume 318 val k = #keep_going (#param gp)
46 :     val glob = foldl (layerwork (k, CT.blayer, farbnode gp))
47 :     val loc =
48 :     foldl (layerwork (k, CT.blayer,
49 :     Option.map CT.bnofilter o bnode gp))
50 : blume 294
51 : blume 299 fun bn (DG.PNODE p) = SOME (CT.primitive gp p)
52 : blume 369 | bn (node as DG.BNODE n) = let
53 : blume 295 val { bininfo, localimports = li, globalimports = gi } = n
54 :     in
55 : blume 351 case StableMap.find (!stablecache, bininfo) of
56 :     SOME r => r
57 :     | NONE => let
58 :     fun mkenv () =
59 :     loc (glob (SOME (CT.bpervasive gp)) gi) li
60 : blume 369 val r = CT.dostable (bininfo, mkenv, gp, node)
61 : blume 351 in
62 :     stablecache :=
63 :     StableMap.insert (!stablecache, bininfo, r);
64 :     r
65 :     end
66 : blume 295 end
67 :     in
68 : blume 301 (* don't eta-reduce this -- it'll lead to an infinite loop! *)
69 :     bn n
70 : blume 295 end
71 : blume 294
72 : blume 295 and farbnode gp (f, n) =
73 :     case (bnode gp n, f) of
74 :     (NONE, _) => NONE
75 :     | (SOME d, NONE) => SOME (CT.bnofilter d)
76 :     | (SOME d, SOME s) => SOME (CT.bfilter (d, s))
77 :    
78 : blume 369 fun snode gp (node as DG.SNODE n) = let
79 : blume 295
80 : blume 318 val k = #keep_going (#param gp)
81 :     val glob =
82 :     foldl (layerwork (k, CT.layer, farsbnode gp))
83 :     val loc =
84 :     foldl (layerwork (k, CT.layer,
85 :     Option.map CT.nofilter o snode gp))
86 : blume 295
87 :     val { smlinfo, localimports = li, globalimports = gi } = n
88 :     in
89 : blume 351 case SmlInfoMap.find (!smlcache, smlinfo) of
90 :     SOME r => r
91 :     | NONE => let
92 :     val pe = SOME (CT.pervasive gp)
93 :     val ge = glob pe gi
94 :     val e = loc ge li
95 :     val r = case e of
96 :     NONE => NONE
97 : blume 369 | SOME e => CT.dosml (smlinfo, e, gp, node)
98 : blume 351 in
99 :     smlcache := SmlInfoMap.insert (!smlcache, smlinfo, r);
100 :     r
101 :     end
102 : blume 295 end
103 :    
104 :     and sbnode gp (DG.SB_BNODE b) = bnode gp b
105 :     | sbnode gp (DG.SB_SNODE s) = snode gp s
106 :    
107 :     and farsbnode gp (f, n) =
108 :     case (sbnode gp n, f) of
109 :     (NONE, _) => NONE
110 :     | (SOME d, NONE) => SOME (CT.nofilter d)
111 :     | (SOME d, SOME s) => SOME (CT.filter (d, s))
112 : blume 314
113 :     fun impexp gp (n, _) = Option.map CT.env2result (farsbnode gp n)
114 :    
115 : blume 355 fun impexpmap gp m =
116 : blume 318 (foldl (layerwork (#keep_going (#param gp),
117 :     CT.rlayer,
118 :     impexp gp))
119 :     (SOME CT.empty)
120 : blume 355 (SymbolMap.listItems m))
121 : blume 351 before reset ()
122 : blume 355
123 :     fun group gp (GG.GROUP { exports, ... }) = impexpmap gp exports
124 : blume 295 end
125 : blume 294 end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0