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 283, Wed May 19 08:20:58 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      type impexp = DependencyGraph.impexp      type impexp = DependencyGraph.impexp
10    
# Line 5  Line 12 
12          { imports: impexp SymbolMap.map,          { imports: impexp SymbolMap.map,
13            gimports: impexp SymbolMap.map,            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              subgroups: GroupGraph.group list }
17          * SymbolSet.set option          (* filter *)          * SymbolSet.set option          (* filter *)
18          * (string -> unit)              (* error *)          * (string -> unit)              (* error *)
19            * GeneralParams.info
20          ->          ->
21          impexp SymbolMap.map            (* exports *)          impexp SymbolMap.map            (* exports *)
22  end  end
# Line 19  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      type impexp = DG.impexp      type impexp = DG.impexp
36    
37      fun look otherwise DG.EMPTY s = otherwise s      fun look otherwise DE.EMPTY s = otherwise s
38        | look otherwise (DG.BINDING (s', v)) s =        | 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 (coll, fopt, error) = let      fun build (coll, fopt, error, gp) = let
51          val { imports, gimports, smlfiles, localdefs } = coll          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 47  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 85  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 137  Line 141 
141                  fun lookfar () =                  fun lookfar () =
142                      case SM.find (imports, 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 159  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 176  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 252  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 sbnodes * env *)          (* converting smlinfos to sbnodes * env *)
# Line 290  Line 265 
265                       * imports.  In either case, it is necessary to strengthen                       * imports.  In either case, it is necessary to strengthen
266                       * the filter attached to each node. *)                       * the filter attached to each node. *)
267                      fun strengthen ((fopt', sbn), e) = let                      fun strengthen ((fopt', sbn), e) = let
                         exception Unbound  
                         fun addB (s, e') = let  
                             val v = look (fn _ => raise Unbound) e s  
                         in  
                             DG.LAYER (DG.BINDING (s, v), e')  
                         end handle Unbound => e'  
                         val new_e = SS.foldl addB DG.EMPTY ss  
268                          val new_fopt =                          val new_fopt =
269                              case fopt' of                              case fopt' of
270                                  NONE => fopt                                  NONE => fopt
271                                | SOME ss' => SOME (SS.intersection (ss, ss'))                                | SOME ss' => SOME (SS.intersection (ss, ss'))
272                      in                      in
273                          ((new_fopt, sbn), new_e)                          ((new_fopt, sbn), DE.FILTER (ss, e))
274                      end                      end
275                      val availablemap = SM.unionWith #1 (localmap, imports)                      val availablemap = SM.unionWith #1 (localmap, imports)
276                      fun addNodeFor (s, m) =                      fun addNodeFor (s, m) =
# Line 315  Line 283 
283                  in                  in
284                      SS.foldl addNodeFor SM.empty ss                      SS.foldl addNodeFor SM.empty ss
285                  end                  end
   
         (* Find dangling (unreachable) nodes.  
          * For this, we first build an AbsPathSet.set of all the SNODEs in the  
          * exporct map.  Then we build another such set that is the domain of  
          * the root set.  By subtracting the former from the latter we get  
          * the set of dangling nodes. *)  
         fun addR (p, _, s) = AbsPathSet.add (s, p)  
         val rootPathSet = AbsPathMap.foldli addR AbsPathSet.empty (!rs)  
   
         fun addE (((_, DG.SB_SNODE (DG.SNODE { smlinfo =i, ... })), _), s) =  
             AbsPathSet.add (s, SmlInfo.sourcepath i)  
           | addE (_, s) = s  
         val exportPathSet = SM.foldl addE AbsPathSet.empty exports  
   
         val danglingPaths = AbsPathSet.difference (rootPathSet, exportPathSet)  
   
         fun complainDangle p = let  
             val i = valOf (AbsPathMap.find (!rs, p))  
         in  
             SmlInfo.error i  
                 (concat ["compilation unit ", AbsPath.spec p, " unreachable"])  
                 EM.nullErrorBody  
         end  
286      in      in
         AbsPathSet.app complainDangle danglingPaths;  
287          exports          exports
288      end      end
289  end  end

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

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