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

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