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

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/depend/build.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/depend/build.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 278, Mon May 17 14:53:49 1999 UTC revision 299, Thu May 27 13:53:27 1999 UTC
# Line 1  Line 1 
1  structure BuildDepend = struct  (*
2     * Build the dependency graph for one group/library.
3     *
4     * (C) 1999 Lucent Technologies, Bell Laboratories
5     *
6     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7     *)
8    signature BUILDDEPEND = sig
9        type impexp = DependencyGraph.impexp
10    
11        val build :
12            { imports: impexp SymbolMap.map,
13              gimports: impexp SymbolMap.map,
14              smlfiles: SmlInfo.info list,
15              localdefs: SmlInfo.info SymbolMap.map,
16              subgroups: GroupGraph.group list }
17            * SymbolSet.set option          (* filter *)
18            * (string -> unit)              (* error *)
19            * GeneralParams.info
20            ->
21            impexp SymbolMap.map            (* exports *)
22    end
23    
24    structure BuildDepend :> BUILDDEPEND = struct
25    
26      structure S = Symbol      structure S = Symbol
27      structure SS = SymbolSet      structure SS = SymbolSet
28      structure SM = SymbolMap      structure SM = SymbolMap
29      structure SK = Skeleton      structure SK = Skeleton
30      structure DG = DependencyGraph      structure DG = DependencyGraph
31        structure DE = DAEnv
32        structure EM = GenericVC.ErrorMsg
33        structure SP = GenericVC.SymPath
34    
35      fun look otherwise DG.EMPTY s = otherwise s      type impexp = DG.impexp
36        | look otherwise (DG.BINDING (s', v)) s =  
37        fun look otherwise DE.EMPTY s = otherwise s
38          | look otherwise (DE.BINDING (s', v)) s =
39          if S.eq (s, s') then v else otherwise s          if S.eq (s, s') then v else otherwise s
40        | look otherwise (DG.LAYER (e, e')) s = look (look otherwise e') e s        | look otherwise (DE.LAYER (e, e')) s = look (look otherwise e') e s
41        | look otherwise (DG.FCTENV { looker, domain }) s =        | look otherwise (DE.FCTENV { looker, domain }) s =
42          (case looker s of NONE => otherwise s | SOME v => v)          (case looker s of NONE => otherwise s | SOME v => v)
43          | look otherwise (DE.FILTER (ss, e)) s =
44            if SymbolSet.member (ss, s) then look otherwise e s else otherwise s
45    
46        (* get the description for a symbol *)
47        fun symDesc (s, r) =
48            S.nameSpaceToString (S.nameSpace s) :: " " :: S.name s :: r
49    
50      fun build { subexports, smlfiles, localdefs } = let      fun build (coll, fopt, error, gp) = let
51            val { imports, gimports, smlfiles, localdefs, subgroups } = coll
52    
53          (* the "blackboard" where analysis results are announced *)          (* the "blackboard" where analysis results are announced *)
54          (* (also used for cycle detection) *)          (* (also used for cycle detection) *)
# Line 23  Line 58 
58              (bb := AbsPathMap.insert (!bb, SmlInfo.sourcepath i, SOME r); r)              (bb := AbsPathMap.insert (!bb, SmlInfo.sourcepath i, SOME r); r)
59          fun fetch i = AbsPathMap.find (!bb, SmlInfo.sourcepath i)          fun fetch i = AbsPathMap.find (!bb, SmlInfo.sourcepath i)
60    
         (* the "root set" *)  
         val rs = ref AbsPathSet.empty  
         fun addRoot i = rs := AbsPathSet.add (!rs, SmlInfo.sourcepath i)  
         fun delRoot i =  
             (rs := AbsPathSet.delete (!rs, SmlInfo.sourcepath i))  
             handle LibBase.NotFound => ()  
   
61          (* - get the result from the blackboard if it is there *)          (* - get the result from the blackboard if it is there *)
62          (* - otherwise trigger analysis *)          (* - otherwise trigger analysis *)
63          (* - detect cycles using locking *)          (* - detect cycles using locking *)
64          (* - maintain root set *)          (* - maintain root set *)
65          fun getResult (i, history) =          fun getResult (i, history) =
66              case fetch i of              case fetch i of
67                  NONE => (lock i; addRoot i; release (i, analyze (i, history)))                  NONE => (lock i; release (i, analyze (i, history)))
68                | SOME (SOME r) => (delRoot i; r)                | SOME (SOME r) => r
69                | SOME NONE => let        (* cycle found --> error message *)                | SOME NONE => let        (* cycle found --> error message *)
70                      val f = SmlInfo.sourcepath i                      val f = SmlInfo.sourcepath i
                     fun symDesc (s, r) =  
                         S.nameSpaceToString (S.nameSpace s) :: " " ::  
                         S.name s :: r  
71                      fun pphist pps = let                      fun pphist pps = let
72                          fun recur [] = () (* shouldn't happen *)                          fun recur (_, []) = () (* shouldn't happen *)
73                            | recur ((s, i') :: r) = let                            | recur (n'', (s, i') :: r) = let
74                                  val f' = SmlInfo.sourcepath i'                                  val f' = SmlInfo.sourcepath i'
75                                    val n' = AbsPath.spec f'
76                                  val _ =                                  val _ =
77                                      if AbsPath.compare (f, f') = EQUAL then ()                                      if SmlInfo.eq (i, i') then ()
78                                      else recur r                                      else recur (n', r)
                                 val n' = AbsPath.name f'  
79                                  val l =                                  val l =
80                                      n' :: " refers to " ::                                      n' :: " refers to " ::
81                                      symDesc (s, [" defined in ..."])                                      symDesc (s, [" defined in ", n''])
82                              in                              in
83                                  app (PrettyPrint.add_string pps) l;                                  app (PrettyPrint.add_string pps) l;
84                                  PrettyPrint.add_newline pps                                  PrettyPrint.add_newline pps
85                              end                              end
86                      in                      in
87                          recur history;                          PrettyPrint.add_newline pps;
88                          PrettyPrint.add_string pps (AbsPath.name f);                          recur (AbsPath.spec f, history)
                         PrettyPrint.add_newline pps  
89                      end                      end
90                  in                  in
91                      SmlInfo.error i "cyclic ML dependencies" pphist                      SmlInfo.error gp i EM.COMPLAIN
92                             "cyclic ML dependencies" pphist;
93                        release (i, (DG.SNODE { smlinfo = i,
94                                                localimports = [],
95                                                globalimports = [] },
96                                     DE.EMPTY))
97                  end                  end
98    
99            (* do the actual analysis of an ML source and generate the
100             * corresponding node *)
101          and analyze (i, history) = let          and analyze (i, history) = let
102  (*          fun lookimport s =              val li = ref []
103                val gi = ref []
104    
105                (* register a local import *)
106                fun localImport n =
107                    if List.exists (fn n' => DG.seq (n, n')) (!li) then ()
108                    else li := n :: !li
109    
110                (* register a global import, maintain filter sets *)
111                fun globalImport (f, n) = let
112                    fun sameN (_, n') = DG.sbeq (n, n')
113                in
114                    case List.find sameN (!gi) of
115                        NONE => gi := (f, n) :: !gi (* brand new *)
116                      | SOME (NONE, n') => () (* no filter -> no change *)
117                      | SOME (SOME f', n') => let
118                            (* there is a filter...
119                             *  calculate "union", see if there is a change,
120                             *  and if so, replace the filter *)
121                            fun replace filt =
122                                gi := (filt, n) :: List.filter (not o sameN) (!gi)
123                        in
124                            case f of
125                                NONE => replace NONE
126                              | SOME f =>
127                                    if SS.equal (f, f') then ()
128                                    else replace (SOME (SS.union (f, f')))
129                        end
130                end
131    
132                val f = SmlInfo.sourcepath i
133                fun isSelf i' = SmlInfo.eq (i, i')
134    
135                exception Lookup
136    
137                (* lookup function for things not defined in the same ML file.
138                 * As a side effect, this function registers local and
139                 * global imports. *)
140                fun lookimport s = let
141                    fun lookfar () =
142                        case SM.find (imports, s) of
143                            SOME (farn, e) => (globalImport farn; e)
144                          | NONE => (SmlInfo.error gp i EM.COMPLAIN
145                                      (concat (AbsPath.spec f ::
146                                               ": reference to unknown " ::
147                                               symDesc (s, [])))
148                                      EM.nullErrorBody;
149                                     raise Lookup)
150                in
151                  case SM.find (localdefs, s) of                  case SM.find (localdefs, s) of
152                      SOME i' => let                      SOME i' =>
153                          val (_, e) = getResult (i', (s, i) :: history)                          if isSelf i' then lookfar ()
154                            else let
155                                val (n, e) = getResult (i', (s, i) :: history)
156                      in                      in
157                                localImport n;
158                          e                          e
159                      end                      end
160                    | NONE =>                    | NONE => lookfar ()
161                end
162    
163                (* build the lookup function for DG.env *)
164                val lookup_exn = look lookimport
165    
166                fun lookSymPath e (SP.SPATH []) = DE.EMPTY
167                  | lookSymPath e (SP.SPATH (p as (h :: t))) = let
168                        fun dotPath [] = []
169                          | dotPath [s] = [S.name s]
170                          | dotPath (h :: t) = S.name h :: "." :: dotPath t
171                        fun complain s =
172                            (SmlInfo.error gp i EM.COMPLAIN
173                              (concat
174                               (AbsPath.spec f ::
175                                ": undefined " ::
176                                symDesc (s, " in path " :: dotPath p)))
177                              EM.nullErrorBody;
178                             raise Lookup)
179                        val lookup_exn' = look complain
180                        fun loop (e, []) = e
181                          | loop (e, h :: t) = loop (lookup_exn' e h, t)
182                    in
183                        loop (lookup_exn e h, t) handle Lookup => DE.EMPTY
184                    end
185    
186                fun lookup e s = lookup_exn e s handle Lookup => DE.EMPTY
187    
188                (* "eval" -- compute the export environment of a skeleton *)
189                fun eval sk = let
190                    fun evalDecl e (SK.Bind (name, def)) =
191                        DE.BINDING (name, evalModExp e def)
192                      | evalDecl e (SK.Local (d1, d2)) =
193                        evalDecl (DE.LAYER (evalDecl e d1, e)) d2
194                      | evalDecl e (SK.Seq l) = evalSeqDecl e l
195                      | evalDecl e (SK.Par []) = DE.EMPTY
196                      | evalDecl e (SK.Par (h :: t)) =
197                        foldl (fn (x, r) => DE.LAYER (evalDecl e x, r))
198                              (evalDecl e h) t
199                      | evalDecl e (SK.Open s) = evalModExp e s
200                      | evalDecl e (SK.Ref s) =
201                        (SS.app (ignore o lookup e) s; DE.EMPTY)
202    
203                    and evalSeqDecl e [] = DE.EMPTY
204                      | evalSeqDecl e (h :: t) = let
205                            fun one (d, e') =
206                                DE.LAYER (evalDecl (DE.LAYER (e', e)) d, e')
207                        in
208                            foldl one (evalDecl e h) t
209                        end
210    
211                    and evalModExp e (SK.Var sp) = lookSymPath e sp
212                      | evalModExp e (SK.Decl l) = evalSeqDecl e l
213                      | evalModExp e (SK.Let (d, m)) =
214                        evalModExp (DE.LAYER (evalSeqDecl e d, e)) m
215                      | evalModExp e (SK.Ign1 (m1, m2)) =
216                        (ignore (evalModExp e m1); evalModExp e m2)
217                in
218                    evalDecl DE.EMPTY sk
219                end
220    
221              val lookup = look lookimport *)              val e = eval (SmlInfo.skeleton gp i)
222                val n = DG.SNODE { smlinfo = i,
223                                   localimports = !li,
224                                   globalimports = !gi }
225          in          in
226              Dummy.f ()              (n, e)
227          end          end
228    
229          (* run the analysis on one ML file -- causing the blackboard          (* run the analysis on one ML file -- causing the blackboard
230           * and the root set to be updated accordingly *)           * to be updated accordingly *)
231          fun doSmlFile i = ignore (getResult (i, []))          fun doSmlFile i = ignore (getResult (i, []))
232    
233            (* converting smlinfos to sbnodes * env *)
234            fun i2sbn i = let
235                val (sn, e) = valOf (valOf (fetch i))
236            in
237                (DG.SB_SNODE sn, e)
238            end
239    
240            (* run the analysis *)
241            val _ = app doSmlFile smlfiles
242    
243            fun addDummyFilt (sbn, e) = ((NONE, sbn), e)
244    
245            (* First we make a map of all locally defined symbols to
246             * the local "far sb node"
247             * but with only a dummy filter attached.
248             * This makes it consistent with the current state
249             * of "imports" and "gimports" where there can be filters, but
250             * where those filters are not yet strengthened according to fopt *)
251            val localmap = SM.map (addDummyFilt o i2sbn) localdefs
252    
253            val exports =
254                case fopt of
255                    NONE =>
256                        (* There is no filter -- so we are in an ordinary
257                         * group and should export all gimports as well as
258                         * all local definitions.
259                         * No filter strengthening is necessary. *)
260                        SM.unionWith #1 (localmap, gimports)
261                  | SOME ss => let
262                        (* There is a filter.
263                         * We export only the things in the filter.
264                         * They can be taken from either localmap or else from
265                         * imports.  In either case, it is necessary to strengthen
266                         * the filter attached to each node. *)
267                        fun strengthen ((fopt', sbn), e) = let
268                            val new_fopt =
269                                case fopt' of
270                                    NONE => fopt
271                                  | SOME ss' => SOME (SS.intersection (ss, ss'))
272                        in
273                            ((new_fopt, sbn), DE.FILTER (ss, e))
274                        end
275                        val availablemap = SM.unionWith #1 (localmap, imports)
276                        fun addNodeFor (s, m) =
277                            case SM.find (availablemap, s) of
278                                SOME n => SM.insert (m, s, strengthen n)
279                              | NONE => (error
280                                          (concat ("exported " ::
281                                                   symDesc (s, [" not defined"])));
282                                         m)
283                    in
284                        SS.foldl addNodeFor SM.empty ss
285                    end
286      in      in
287          Dummy.f ()          exports
288      end      end
289  end  end

Legend:
Removed from v.278  
changed lines
  Added in v.299

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