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 282, Wed May 19 05:14:03 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.farsbnode * 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.snode SymbolMap.map,            subgroups: GroupGraph.group list }
17               rootset: DependencyGraph.snode 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 77  Line 88 
88                          recur (AbsPath.spec f, history)                          recur (AbsPath.spec f, history)
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,                      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 127  Line 139 
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, [])))
# Line 151  Line 163 
163              (* build the lookup function for DG.env *)              (* build the lookup function for DG.env *)
164              val lookup_exn = 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
171                      fun complain s =                      fun complain s =
172                          (SmlInfo.error i                          (SmlInfo.error gp i EM.COMPLAIN
173                            (concat                            (concat
174                             (AbsPath.spec f ::                             (AbsPath.spec f ::
175                              ": undefined " ::                              ": undefined " ::
# Line 168  Line 180 
180                      fun loop (e, []) = e                      fun loop (e, []) = e
181                        | loop (e, h :: t) = loop (lookup_exn' e h, t)                        | loop (e, h :: t) = loop (lookup_exn' e h, t)
182                  in                  in
183                      loop (lookup_exn e h, t) handle Lookup => DG.EMPTY                      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 => DG.EMPTY              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.SNODE { smlinfo = i,              val n = DG.SNODE { smlinfo = i,
223                                 localimports = !li,                                 localimports = !li,
224                                 globalimports = !gi }                                 globalimports = !gi }
# Line 244  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.282  
changed lines
  Added in v.299

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