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 286, Fri May 21 07:47:16 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 19  Line 26 
26      structure SM = SymbolMap      structure SM = SymbolMap
27      structure SK = Skeleton      structure SK = Skeleton
28      structure DG = DependencyGraph      structure DG = DependencyGraph
29        structure DE = DAEnv
30      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
31      structure SP = GenericVC.SymPath      structure SP = GenericVC.SymPath
32    
33      type impexp = DG.impexp      type impexp = DG.impexp
34    
35      fun look otherwise DG.EMPTY s = otherwise s      fun look otherwise DE.EMPTY s = otherwise s
36        | look otherwise (DG.BINDING (s', v)) s =        | look otherwise (DE.BINDING (s', v)) s =
37          if S.eq (s, s') then v else otherwise s          if S.eq (s, s') then v else otherwise s
38        | 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
39        | look otherwise (DG.FCTENV { looker, domain }) s =        | look otherwise (DE.FCTENV { looker, domain }) s =
40          (case looker s of NONE => otherwise s | SOME v => v)          (case looker s of NONE => otherwise s | SOME v => v)
41          | look otherwise (DE.FILTER (ss, e)) s =
42            if SymbolSet.member (ss, s) then look otherwise e s else otherwise s
43    
44      (* get the description for a symbol *)      (* get the description for a symbol *)
45      fun symDesc (s, r) =      fun symDesc (s, r) =
# Line 47  Line 57 
57              (bb := AbsPathMap.insert (!bb, SmlInfo.sourcepath i, SOME r); r)              (bb := AbsPathMap.insert (!bb, SmlInfo.sourcepath i, SOME r); r)
58          fun fetch i = AbsPathMap.find (!bb, SmlInfo.sourcepath i)          fun fetch i = AbsPathMap.find (!bb, SmlInfo.sourcepath i)
59    
         (* 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 => ()  
   
60          (* - get the result from the blackboard if it is there *)          (* - get the result from the blackboard if it is there *)
61          (* - otherwise trigger analysis *)          (* - otherwise trigger analysis *)
62          (* - detect cycles using locking *)          (* - detect cycles using locking *)
63          (* - maintain root set *)          (* - maintain root set *)
64          fun getResult (i, history) =          fun getResult (i, history) =
65              case fetch i of              case fetch i of
66                  NONE => (lock i; addRoot i; release (i, analyze (i, history)))                  NONE => (lock i; release (i, analyze (i, history)))
67                | SOME (SOME r) => (delRoot i; r)                | SOME (SOME r) => r
68                | SOME NONE => let        (* cycle found --> error message *)                | SOME NONE => let        (* cycle found --> error message *)
69                      val f = SmlInfo.sourcepath i                      val f = SmlInfo.sourcepath i
70                      fun pphist pps = let                      fun pphist pps = let
# Line 89  Line 91 
91                      release (i, (DG.SNODE { smlinfo = i,                      release (i, (DG.SNODE { smlinfo = i,
92                                              localimports = [],                                              localimports = [],
93                                              globalimports = [] },                                              globalimports = [] },
94                                   DG.EMPTY))                                   DE.EMPTY))
95                  end                  end
96    
97          (* do the actual analysis of an ML source and generate the          (* do the actual analysis of an ML source and generate the
# Line 159  Line 161 
161              (* build the lookup function for DG.env *)              (* build the lookup function for DG.env *)
162              val lookup_exn = look lookimport              val lookup_exn = look lookimport
163    
164              fun lookSymPath e (SP.SPATH []) = DG.EMPTY              fun lookSymPath e (SP.SPATH []) = DE.EMPTY
165                | lookSymPath e (SP.SPATH (p as (h :: t))) = let                | lookSymPath e (SP.SPATH (p as (h :: t))) = let
166                      fun dotPath [] = []                      fun dotPath [] = []
167                        | dotPath [s] = [S.name s]                        | dotPath [s] = [S.name s]
# Line 176  Line 178 
178                      fun loop (e, []) = e                      fun loop (e, []) = e
179                        | loop (e, h :: t) = loop (lookup_exn' e h, t)                        | loop (e, h :: t) = loop (lookup_exn' e h, t)
180                  in                  in
181                      loop (lookup_exn e h, t) handle Lookup => DG.EMPTY                      loop (lookup_exn e h, t) handle Lookup => DE.EMPTY
182                  end                  end
183    
184              fun lookup e s = lookup_exn e s handle Lookup => DG.EMPTY              fun lookup e s = lookup_exn e s handle Lookup => DE.EMPTY
185    
186              (* "eval" -- compute the export environment of a skeleton *)              (* "eval" -- compute the export environment of a skeleton *)
187              fun eval sk = let              fun eval sk = let
188                  fun layer' f [] = DG.EMPTY                  fun layer' f [] = DE.EMPTY
189                    | layer' f [x] = f x                    | layer' f [x] = f x
190                    | layer' f (h :: t) =                    | layer' f (h :: t) =
191                      foldl (fn (x, r) => DG.LAYER (f x, r)) (f h) t                      foldl (fn (x, r) => DE.LAYER (f x, r)) (f h) t
192    
193                  fun evalDecl e (SK.StrDecl l) = let                  fun evalDecl e (SK.Bind (name, def)) =
194                          fun one { name, def, constraint = NONE } =                      DE.BINDING (name, evalModExp e def)
195                              DG.BINDING (name, evalStrExp e def)                    | evalDecl e (SK.Local (d1, d2)) =
196                            | one { name, def, constraint = SOME constr } =                      evalDecl (DE.LAYER (evalDecl e d1, e)) d2
197                              (ignore (evalStrExp e def);                    | evalDecl e (SK.Seq l) =
                              DG.BINDING (name, evalStrExp e constr))  
                     in  
                         layer' one l  
                     end  
                   | evalDecl e (SK.FctDecl l) = let  
                         fun one { name, def } =  
                             DG.BINDING (name, evalFctExp e def)  
                     in  
                         layer' one l  
                     end  
                   | evalDecl e (SK.LocalDecl (d1, d2)) =  
                     evalDecl (DG.LAYER (evalDecl e d1, e)) d2  
                   | evalDecl e (SK.SeqDecl l) =  
198                      foldl (fn (d, e') =>                      foldl (fn (d, e') =>
199                             DG.LAYER (evalDecl (DG.LAYER (e', e)) d, e'))                             DE.LAYER (evalDecl (DE.LAYER (e', e)) d, e'))
200                            DG.EMPTY l                            DE.EMPTY l
201                    | evalDecl e (SK.OpenDecl l) = layer' (evalStrExp e) l                    | evalDecl e (SK.Par l) = layer' (evalDecl e) l
202                    | evalDecl e (SK.DeclRef s) =                    | evalDecl e (SK.Open s) = evalModExp e s
203                      (SS.app (ignore o lookup e) s; DG.EMPTY)                    | evalDecl e (SK.Ref s) =
204                        (SS.app (ignore o lookup e) s; DE.EMPTY)
205                  and evalStrExp e (SK.VarStrExp sp) = lookSymPath e sp  
206                    | evalStrExp e (SK.BaseStrExp d) = evalDecl e d                  and evalModExp e (SK.Var sp) = lookSymPath e sp
207                    | evalStrExp e (SK.AppStrExp (sp, l)) =                    | evalModExp e (SK.Decl d) = evalDecl e d
208                      (app (ignore o evalStrExp e) l; lookSymPath e sp)                    | evalModExp e (SK.App (sp, l)) =
209                    | evalStrExp e (SK.LetStrExp (d, se)) =                      (app (ignore o evalModExp e) l; lookSymPath e sp)
210                      evalStrExp (DG.LAYER (evalDecl e d, e)) se                    | evalModExp e (SK.Let (d, m)) =
211                    | evalStrExp e (SK.ConStrExp (se1, se2)) =                      evalModExp (DE.LAYER (evalDecl e d, e)) m
212                      (ignore (evalStrExp e se1); evalStrExp e se2)                    | evalModExp e (SK.Con (m1, m2)) =
213                        (ignore (evalModExp e m1); evalModExp e m2)
                 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  
214              in              in
215                  evalDecl DG.EMPTY sk                  evalDecl DE.EMPTY sk
216              end              end
217    
218              val e = eval (SmlInfo.skeleton i)              val e = eval (SmlInfo.skeleton i)
# Line 252  Line 224 
224          end          end
225    
226          (* run the analysis on one ML file -- causing the blackboard          (* run the analysis on one ML file -- causing the blackboard
227           * and the root set to be updated accordingly *)           * to be updated accordingly *)
228          fun doSmlFile i = ignore (getResult (i, []))          fun doSmlFile i = ignore (getResult (i, []))
229    
230          (* converting smlinfos to sbnodes * env *)          (* converting smlinfos to sbnodes * env *)
# Line 290  Line 262 
262                       * imports.  In either case, it is necessary to strengthen                       * imports.  In either case, it is necessary to strengthen
263                       * the filter attached to each node. *)                       * the filter attached to each node. *)
264                      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  
265                          val new_fopt =                          val new_fopt =
266                              case fopt' of                              case fopt' of
267                                  NONE => fopt                                  NONE => fopt
268                                | SOME ss' => SOME (SS.intersection (ss, ss'))                                | SOME ss' => SOME (SS.intersection (ss, ss'))
269                      in                      in
270                          ((new_fopt, sbn), new_e)                          ((new_fopt, sbn), DE.FILTER (ss, e))
271                      end                      end
272                      val availablemap = SM.unionWith #1 (localmap, imports)                      val availablemap = SM.unionWith #1 (localmap, imports)
273                      fun addNodeFor (s, m) =                      fun addNodeFor (s, m) =
# Line 315  Line 280 
280                  in                  in
281                      SS.foldl addNodeFor SM.empty ss                      SS.foldl addNodeFor SM.empty ss
282                  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  
283      in      in
         AbsPathSet.app complainDangle danglingPaths;  
284          exports          exports
285      end      end
286  end  end

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

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