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 280, Tue May 18 09:05:13 1999 UTC revision 299, Thu May 27 13:53:27 1999 UTC
# Line 1  Line 1 
1    (*
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  signature BUILDDEPEND = sig
9      val build : { subexports: (DependencyGraph.farnode * DependencyGraph.env)      type impexp = DependencyGraph.impexp
10                                  SymbolMap.map,  
11        val build :
12            { imports: impexp SymbolMap.map,
13              gimports: impexp SymbolMap.map,
14                    smlfiles: SmlInfo.info list,                    smlfiles: SmlInfo.info list,
15                    localdefs: SmlInfo.info SymbolMap.map }            localdefs: SmlInfo.info SymbolMap.map,
16          -> { nodemap: DependencyGraph.node SymbolMap.map,            subgroups: GroupGraph.group list }
17               rootset: DependencyGraph.node list }          * SymbolSet.set option          (* filter *)
18            * (string -> unit)              (* error *)
19            * GeneralParams.info
20            ->
21            impexp SymbolMap.map            (* exports *)
22  end  end
23    
24  structure BuildDepend :> BUILDDEPEND = struct  structure BuildDepend :> BUILDDEPEND = struct
# Line 14  Line 28 
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      structure EM = GenericVC.ErrorMsg
33      structure SP = GenericVC.SymPath      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 *)      (* get the description for a symbol *)
47      fun symDesc (s, r) =      fun symDesc (s, r) =
48          S.nameSpaceToString (S.nameSpace s) :: " " ::          S.nameSpaceToString (S.nameSpace s) :: " " :: S.name s :: r
         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 39  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 AbsPathMap.empty  
         fun addRoot i =  
             rs := AbsPathMap.insert (!rs, SmlInfo.sourcepath i, i)  
         fun delRoot i =  
             (rs := #1 (AbsPathMap.remove (!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
71                      fun pphist pps = let                      fun pphist pps = let
# Line 74  Line 85 
85                              end                              end
86                      in                      in
87                          PrettyPrint.add_newline pps;                          PrettyPrint.add_newline pps;
88                          recur (AbsPath.spec f, history);                          recur (AbsPath.spec f, history)
                         PrettyPrint.add_string pps "...";  
                         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                      release (i, (DG.NODE { smlinfo = i,                           "cyclic ML dependencies" pphist;
93                        release (i, (DG.SNODE { smlinfo = i,
94                                             localimports = [],                                             localimports = [],
95                                             globalimports = [] },                                             globalimports = [] },
96                                   DG.EMPTY))                                   DE.EMPTY))
97                  end                  end
98    
99          (* do the actual analysis of an ML source and generate the          (* do the actual analysis of an ML source and generate the
# Line 93  Line 103 
103              val gi = ref []              val gi = ref []
104    
105              (* register a local import *)              (* register a local import *)
106              fun localImport (n as DG.NODE { smlinfo = i, ... }) = let              fun localImport n =
107                  fun sameNode (DG.NODE { smlinfo = i', ... }) =                  if List.exists (fn n' => DG.seq (n, n')) (!li) then ()
                     SmlInfo.eq (i, i')  
             in  
                 if List.exists sameNode (!li) then ()  
108                  else li := n :: !li                  else li := n :: !li
             end  
109    
110              (* register a global import, maintain filter sets *)              (* register a global import, maintain filter sets *)
111              fun globalImport (farn as DG.PNODE p) = let              fun globalImport (f, n) = let
112                      fun sameFarNode (DG.FARNODE _) = false                  fun sameN (_, n') = DG.sbeq (n, n')
113                        | sameFarNode (DG.PNODE p') = Primitive.eq (p, p')              in
114                  in                  case List.find sameN (!gi) of
115                      if List.exists sameFarNode (!gi) then ()                      NONE => gi := (f, n) :: !gi (* brand new *)
116                      else gi := farn :: !gi                    | SOME (NONE, n') => () (* no filter -> no change *)
117                  end                    | SOME (SOME f', n') => let
               | globalImport (farn as DG.FARNODE (f, n)) = let  
                     fun sameFarNode (DG.PNODE _) = false  
                       | sameFarNode (DG.FARNODE (_, n')) = let  
                             val DG.NODE { smlinfo = i, ... } = n  
                             val DG.NODE { smlinfo = i', ... } = n'  
                         in  
                             SmlInfo.eq (i, i')  
                         end  
                 in  
                     case List.find sameFarNode (!gi) of  
                         NONE => gi := farn :: !gi (* brand new *)  
                       | SOME (DG.FARNODE (NONE, n')) => ()  
                         (* no filter before -> no change *)  
                       | SOME (DG.FARNODE (SOME f', n')) => let  
118                          (* there is a filter ...                          (* there is a filter ...
119                           *   calculate "union-filter", see if there is                           *  calculate "union", see if there is a change,
120                           *   a change, and if so, replace the filter *)                           *  and if so, replace the filter *)
121                              fun replace filt =                              fun replace filt =
122                                  gi :=                              gi := (filt, n) :: List.filter (not o sameN) (!gi)
                                    (DG.FARNODE (filt, n)) ::  
                                    (List.filter (not o sameFarNode) (!gi))  
123                          in                          in
124                              case f of                              case f of
125                                  NONE => replace NONE                                  NONE => replace NONE
# Line 137  Line 127 
127                                      if SS.equal (f, f') then ()                                      if SS.equal (f, f') then ()
128                                      else replace (SOME (SS.union (f, f')))                                      else replace (SOME (SS.union (f, f')))
129                          end                          end
   
                       | SOME (DG.PNODE _) => () (* cannot happen *)  
130                  end                  end
131    
132              val f = SmlInfo.sourcepath i              val f = SmlInfo.sourcepath i
133              fun isSelf i' = SmlInfo.eq (i, i')              fun isSelf i' = SmlInfo.eq (i, i')
134    
135                exception Lookup
136    
137              (* lookup function for things not defined in the same ML file.              (* lookup function for things not defined in the same ML file.
138               * As a side effect, this function registers local and               * As a side effect, this function registers local and
139               * global imports. *)               * global imports. *)
140              fun lookimport s = let              fun lookimport s = let
141                  fun lookfar () =                  fun lookfar () =
142                      case SM.find (subexports, s) of                      case SM.find (imports, s) of
143                          SOME (farn, e) => (globalImport farn; e)                          SOME (farn, e) => (globalImport farn; e)
144                        | NONE => (SmlInfo.error i                        | NONE => (SmlInfo.error gp i EM.COMPLAIN
145                                    (concat (AbsPath.spec f ::                                    (concat (AbsPath.spec f ::
146                                             ": reference to unknown " ::                                             ": reference to unknown " ::
147                                             symDesc (s, [])))                                             symDesc (s, [])))
148                                    EM.nullErrorBody;                                    EM.nullErrorBody;
149                                   DG.EMPTY)                                   raise Lookup)
150              in              in
151                  case SM.find (localdefs, s) of                  case SM.find (localdefs, s) of
152                      SOME i' =>                      SOME i' =>
# Line 171  Line 161 
161              end              end
162    
163              (* build the lookup function for DG.env *)              (* build the lookup function for DG.env *)
164              val lookup = look lookimport              val lookup_exn = look lookimport
165    
166              fun lookSymPath e (SP.SPATH []) = DG.EMPTY              fun lookSymPath e (SP.SPATH []) = DE.EMPTY
167                | lookSymPath e (SP.SPATH (p as (h :: t))) = let                | lookSymPath e (SP.SPATH (p as (h :: t))) = let
168                      fun dotPath [] = []                      fun dotPath [] = []
169                        | dotPath [s] = [S.name s]                        | dotPath [s] = [S.name s]
170                        | dotPath (h :: t) = S.name h :: "." :: dotPath t                        | dotPath (h :: t) = S.name h :: "." :: dotPath t
                     val firstTime = ref true  
171                      fun complain s =                      fun complain s =
172                          if !firstTime then                          (SmlInfo.error gp i EM.COMPLAIN
                             (SmlInfo.error i  
173                               (concat                               (concat
174                                ("undefined " ::                             (AbsPath.spec f ::
175                                ": undefined " ::
176                                 symDesc (s, " in path " :: dotPath p)))                                 symDesc (s, " in path " :: dotPath p)))
177                               EM.nullErrorBody;                               EM.nullErrorBody;
178                               firstTime := false;                           raise Lookup)
179                               DG.EMPTY)                      val lookup_exn' = look complain
                         else DG.EMPTY  
                     val lookup' = look complain  
180                      fun loop (e, []) = e                      fun loop (e, []) = e
181                        | loop (e, h :: t) = loop (lookup' e h, t)                        | loop (e, h :: t) = loop (lookup_exn' e h, t)
182                  in                  in
183                      loop (lookup e h, t)                      loop (lookup_exn e h, t) handle Lookup => DE.EMPTY
184                  end                  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 *)              (* "eval" -- compute the export environment of a skeleton *)
189              fun eval sk = let              fun eval sk = let
190                  fun layer' f [] = DG.EMPTY                  fun evalDecl e (SK.Bind (name, def)) =
191                    | layer' f [x] = f x                      DE.BINDING (name, evalModExp e def)
192                    | layer' f (h :: t) =                    | evalDecl e (SK.Local (d1, d2)) =
193                      foldl (fn (x, r) => DG.LAYER (f x, r)) (f h) t                      evalDecl (DE.LAYER (evalDecl e d1, e)) d2
194                      | evalDecl e (SK.Seq l) = evalSeqDecl e l
195                  fun evalDecl e (SK.StrDecl l) = let                    | evalDecl e (SK.Par []) = DE.EMPTY
196                          fun one { name, def, constraint = NONE } =                    | evalDecl e (SK.Par (h :: t)) =
197                              DG.BINDING (name, evalStrExp e def)                      foldl (fn (x, r) => DE.LAYER (evalDecl e x, r))
198                            | one { name, def, constraint = SOME constr } =                            (evalDecl e h) t
199                              (ignore (evalStrExp e def);                    | evalDecl e (SK.Open s) = evalModExp e s
200                               DG.BINDING (name, evalStrExp e constr))                    | evalDecl e (SK.Ref s) =
201                      in                      (SS.app (ignore o lookup e) s; DE.EMPTY)
202                          layer' one l  
203                      end                  and evalSeqDecl e [] = DE.EMPTY
204                    | evalDecl e (SK.FctDecl l) = let                    | evalSeqDecl e (h :: t) = let
205                          fun one { name, def } =                          fun one (d, e') =
206                              DG.BINDING (name, evalFctExp e def)                              DE.LAYER (evalDecl (DE.LAYER (e', e)) d, e')
207                      in                      in
208                          layer' one l                          foldl one (evalDecl e h) t
209                      end                      end
210                    | evalDecl e (SK.LocalDecl (d1, d2)) =  
211                      evalDecl (DG.LAYER (evalDecl e d1, e)) d2                  and evalModExp e (SK.Var sp) = lookSymPath e sp
212                    | evalDecl e (SK.SeqDecl l) =                    | evalModExp e (SK.Decl l) = evalSeqDecl e l
213                      foldl (fn (d, e') =>                    | evalModExp e (SK.Let (d, m)) =
214                             DG.LAYER (evalDecl (DG.LAYER (e', e)) d, e'))                      evalModExp (DE.LAYER (evalSeqDecl e d, e)) m
215                            DG.EMPTY l                    | evalModExp e (SK.Ign1 (m1, m2)) =
216                    | evalDecl e (SK.OpenDecl l) = layer' (evalStrExp e) l                      (ignore (evalModExp e m1); evalModExp e m2)
                   | evalDecl e (SK.DeclRef s) =  
                     (SS.app (ignore o lookup e) s; DG.EMPTY)  
   
                 and evalStrExp e (SK.VarStrExp sp) = lookSymPath e sp  
                   | evalStrExp e (SK.BaseStrExp d) = evalDecl e d  
                   | evalStrExp e (SK.AppStrExp (sp, l)) =  
                     (app (ignore o evalStrExp e) l; lookSymPath e sp)  
                   | evalStrExp e (SK.LetStrExp (d, se)) =  
                     evalStrExp (DG.LAYER (evalDecl e d, e)) se  
                   | evalStrExp e (SK.ConStrExp (se1, se2)) =  
                     (ignore (evalStrExp e se1); evalStrExp e se2)  
   
                 and evalFctExp e (SK.VarFctExp (sp, feopt)) =  
                     getOpt (Option.map (evalFctExp e) feopt,  
                             lookSymPath e sp)  
                   | evalFctExp e (SK.BaseFctExp x) = let  
                         val { params, body, constraint } = x  
                         val parame = evalDecl e params  
                         val bodye = DG.LAYER (parame, e)  
                     in  
                         getOpt (Option.map (evalStrExp bodye) constraint,  
                                 evalStrExp bodye body)  
                     end  
                   | evalFctExp e (SK.AppFctExp (sp, l, feopt)) =  
                     (app (ignore o evalStrExp e) l;  
                      getOpt (Option.map (evalFctExp e) feopt,  
                              lookSymPath e sp))  
                   | evalFctExp e (SK.LetFctExp (d, fe)) =  
                     evalFctExp (DG.LAYER (evalDecl e d, e)) fe  
217              in              in
218                  evalDecl DG.EMPTY sk                  evalDecl DE.EMPTY sk
219              end              end
220    
221              val e = eval (SmlInfo.skeleton i)              val e = eval (SmlInfo.skeleton gp i)
222              val n = DG.NODE { smlinfo = i,              val n = DG.SNODE { smlinfo = i,
223                                localimports = !li,                                localimports = !li,
224                                globalimports = !gi }                                globalimports = !gi }
225          in          in
# Line 267  Line 227 
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 nodes *)          (* converting smlinfos to sbnodes * env *)
234          val i2n = #1 o valOf o valOf o fetch          fun i2sbn i = let
235                val (sn, e) = valOf (valOf (fetch i))
236      in      in
237                (DG.SB_SNODE sn, e)
238            end
239    
240          (* run the analysis *)          (* run the analysis *)
241          app doSmlFile smlfiles;          val _ = app doSmlFile smlfiles
242          (* generate map from export symbol to node and  
243           * also return the root set *)          fun addDummyFilt (sbn, e) = ((NONE, sbn), e)
244          { nodemap = SM.map i2n localdefs,  
245            rootset = map i2n (AbsPathMap.listItems (!rs)) }          (* 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
287            exports
288      end      end
289  end  end

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

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