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 301 - (view) (download)

1 : blume 295 (*
2 :     * The "generic" compilation traversal functor.
3 :     *
4 :     * (C) 1999 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 :     local
9 :     structure GP = GeneralParams
10 : blume 294 structure DG = DependencyGraph
11 : blume 295 in
12 :     functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig
13 : blume 294
14 : blume 295 type envdelta = CT.envdelta
15 :     type benv = CT.benv
16 :     type env = CT.env
17 : blume 294
18 : blume 299 val bnode : GP.info -> DG.bnode -> envdelta option
19 :     val farbnode : GP.info -> DG.farbnode -> benv option
20 :     val snode : GP.info -> DG.snode -> envdelta option
21 :     val sbnode : GP.info -> DG.sbnode -> envdelta option
22 :     val farsbnode : GP.info -> DG.farsbnode -> env 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 :    
30 :     fun foldlayer_k layer f = let
31 :     fun loop r [] = r
32 :     | loop NONE (h :: t) = (ignore (f h); loop NONE t)
33 :     | loop (SOME e) (h :: t) =
34 :     case f h of
35 :     NONE => loop NONE t
36 :     | SOME e' => loop (SOME (layer (e', e))) t
37 :     in
38 :     loop
39 :     end
40 :    
41 :     fun foldlayer_s layer f NONE l = NONE
42 :     | foldlayer_s layer f (SOME i) l = let
43 :     fun loop e [] = SOME e
44 :     | loop e (h :: t) =
45 :     case f h of
46 :     NONE => NONE
47 :     | SOME e' => loop (layer (e', e)) t
48 : blume 294 in
49 : blume 295 loop i l
50 : blume 294 end
51 :    
52 : blume 301 fun bnode (gp: GP.info) n = let
53 : blume 294
54 : blume 295 val (glob, loc) = let
55 :     val globf = farbnode gp
56 :     val locf = Option.map CT.bnofilter o bnode gp
57 :     fun k f = foldlayer_k CT.blayer f
58 :     fun s f = foldlayer_s CT.blayer f
59 : blume 294 in
60 : blume 299 if #keep_going (#param gp) then (k globf, k locf)
61 : blume 295 else (s globf, s locf)
62 : blume 294 end
63 :    
64 : blume 299 fun bn (DG.PNODE p) = SOME (CT.primitive gp p)
65 : blume 295 | bn (DG.BNODE n) = let
66 :     val { bininfo, localimports = li, globalimports = gi } = n
67 : blume 299 fun mkenv () = loc (glob (SOME (CT.bpervasive gp)) gi) li
68 : blume 295 in
69 : blume 298 CT.dostable (bininfo, mkenv, gp)
70 : blume 295 end
71 :     in
72 : blume 301 (* don't eta-reduce this -- it'll lead to an infinite loop! *)
73 :     bn n
74 : blume 295 end
75 : blume 294
76 : blume 295 and farbnode gp (f, n) =
77 :     case (bnode gp n, f) of
78 :     (NONE, _) => NONE
79 :     | (SOME d, NONE) => SOME (CT.bnofilter d)
80 :     | (SOME d, SOME s) => SOME (CT.bfilter (d, s))
81 :    
82 :     fun snode gp (DG.SNODE n) = let
83 :    
84 :     val (glob, loc) = let
85 :     val globf = farsbnode gp
86 :     val locf = Option.map CT.nofilter o snode gp
87 :     fun k f = foldlayer_k CT.layer f
88 :     fun s f = foldlayer_s CT.layer f
89 :     in
90 : blume 299 if #keep_going (#param gp) then (k globf, k locf)
91 : blume 295 else (s globf, s locf)
92 :     end
93 :    
94 :     val { smlinfo, localimports = li, globalimports = gi } = n
95 : blume 301 val desc = SmlInfo.fullSpec smlinfo
96 :     val pe = SOME (CT.pervasive gp)
97 :     val ge = glob pe gi
98 :     val e = loc ge li
99 : blume 295 in
100 : blume 299 case e of
101 : blume 295 NONE => NONE
102 : blume 299 | SOME e => CT.dosml (smlinfo, e, gp)
103 : blume 295 end
104 :    
105 :     and sbnode gp (DG.SB_BNODE b) = bnode gp b
106 :     | sbnode gp (DG.SB_SNODE s) = snode gp s
107 :    
108 :     and farsbnode gp (f, n) =
109 :     case (sbnode gp n, f) of
110 :     (NONE, _) => NONE
111 :     | (SOME d, NONE) => SOME (CT.nofilter d)
112 :     | (SOME d, SOME s) => SOME (CT.filter (d, s))
113 :     end
114 : blume 294 end

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