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 314 - (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 295 end = struct
24 : blume 294
25 : blume 295 type envdelta = CT.envdelta
26 :     type env = CT.env
27 :     type benv = CT.benv
28 : blume 314 type result = CT.result
29 : blume 295
30 : blume 314 (* This is to prevent re-execution of dosml if the first one failed *)
31 :     local
32 :     val failures = ref SmlInfoSet.empty
33 :     in
34 :     fun dosml (i, e, gp) =
35 :     if SmlInfoSet.member (!failures, i) then NONE
36 :     else case CT.dosml (i, e, gp) of
37 :     SOME r => SOME r
38 :     | NONE => (failures := SmlInfoSet.add (!failures, i); NONE)
39 :     fun clearFailures () = failures := SmlInfoSet.empty
40 :     end
41 :    
42 :     (* To implement "keep_going" we have two different ways to "fold"
43 :     * a "layer" function over a list. The _k version is to be used
44 :     * if keep_going is true, otherwise the _s version applies.
45 :     * Note that there is a bit of typing mystery in the way I use
46 :     * these functions later: I had to be more verbose than I wanted
47 :     * to because of the "value restriction rule" in SML'97. *)
48 : blume 295 fun foldlayer_k layer f = let
49 :     fun loop r [] = r
50 :     | loop NONE (h :: t) = (ignore (f h); loop NONE t)
51 :     | loop (SOME e) (h :: t) =
52 :     case f h of
53 :     NONE => loop NONE t
54 :     | SOME e' => loop (SOME (layer (e', e))) t
55 :     in
56 :     loop
57 :     end
58 :    
59 :     fun foldlayer_s layer f NONE l = NONE
60 :     | foldlayer_s layer f (SOME i) l = let
61 :     fun loop e [] = SOME e
62 :     | loop e (h :: t) =
63 :     case f h of
64 :     NONE => NONE
65 :     | SOME e' => loop (layer (e', e)) t
66 : blume 294 in
67 : blume 295 loop i l
68 : blume 294 end
69 :    
70 : blume 301 fun bnode (gp: GP.info) n = let
71 : blume 294
72 : blume 295 val (glob, loc) = let
73 :     val globf = farbnode gp
74 :     val locf = Option.map CT.bnofilter o bnode gp
75 :     fun k f = foldlayer_k CT.blayer f
76 :     fun s f = foldlayer_s CT.blayer f
77 : blume 294 in
78 : blume 299 if #keep_going (#param gp) then (k globf, k locf)
79 : blume 295 else (s globf, s locf)
80 : blume 294 end
81 :    
82 : blume 299 fun bn (DG.PNODE p) = SOME (CT.primitive gp p)
83 : blume 295 | bn (DG.BNODE n) = let
84 :     val { bininfo, localimports = li, globalimports = gi } = n
85 : blume 299 fun mkenv () = loc (glob (SOME (CT.bpervasive gp)) gi) li
86 : blume 295 in
87 : blume 298 CT.dostable (bininfo, mkenv, gp)
88 : blume 295 end
89 :     in
90 : blume 301 (* don't eta-reduce this -- it'll lead to an infinite loop! *)
91 :     bn n
92 : blume 295 end
93 : blume 294
94 : blume 295 and farbnode gp (f, n) =
95 :     case (bnode gp n, f) of
96 :     (NONE, _) => NONE
97 :     | (SOME d, NONE) => SOME (CT.bnofilter d)
98 :     | (SOME d, SOME s) => SOME (CT.bfilter (d, s))
99 :    
100 :     fun snode gp (DG.SNODE n) = let
101 :    
102 :     val (glob, loc) = let
103 :     val globf = farsbnode gp
104 :     val locf = Option.map CT.nofilter o snode gp
105 :     fun k f = foldlayer_k CT.layer f
106 :     fun s f = foldlayer_s CT.layer f
107 :     in
108 : blume 299 if #keep_going (#param gp) then (k globf, k locf)
109 : blume 295 else (s globf, s locf)
110 :     end
111 :    
112 :     val { smlinfo, localimports = li, globalimports = gi } = n
113 : blume 301 val desc = SmlInfo.fullSpec smlinfo
114 :     val pe = SOME (CT.pervasive gp)
115 :     val ge = glob pe gi
116 :     val e = loc ge li
117 : blume 295 in
118 : blume 299 case e of
119 : blume 295 NONE => NONE
120 : blume 314 | SOME e => dosml (smlinfo, e, gp)
121 : blume 295 end
122 :    
123 :     and sbnode gp (DG.SB_BNODE b) = bnode gp b
124 :     | sbnode gp (DG.SB_SNODE s) = snode gp s
125 :    
126 :     and farsbnode gp (f, n) =
127 :     case (sbnode gp n, f) of
128 :     (NONE, _) => NONE
129 :     | (SOME d, NONE) => SOME (CT.nofilter d)
130 :     | (SOME d, SOME s) => SOME (CT.filter (d, s))
131 : blume 314
132 :     fun impexp gp (n, _) = Option.map CT.env2result (farsbnode gp n)
133 :    
134 :     fun group gp (GG.GROUP { exports, ... }) = let
135 :     val fl =
136 :     if #keep_going (#param gp) then foldlayer_k else foldlayer_s
137 :     in
138 :     (fl CT.rlayer (impexp gp)
139 :     (SOME CT.empty)
140 :     (SymbolMap.listItems exports))
141 :     before clearFailures ()
142 :     end
143 : blume 295 end
144 : blume 294 end

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