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/compile/link.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/compile/link.sml

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

revision 399, Thu Aug 26 09:55:09 1999 UTC revision 404, Wed Sep 1 07:03:22 1999 UTC
# Line 1  Line 1 
1    (*
2     * Link traversals.
3     *   - manages shared state
4     *
5     * (C) 1999 Lucent Technologies, Bell Laboratories
6     *
7     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
8     *)
9  local  local
10      structure GP = GeneralParams      structure GP = GeneralParams
11      structure DG = DependencyGraph      structure DG = DependencyGraph
# Line 10  Line 18 
18      type env = E.dynenv      type env = E.dynenv
19  in  in
20      signature LINK = sig      signature LINK = sig
21          val registerGroup : GG.group -> unit  
22            type bfc
23            type bfcGetter = SmlInfo.info -> bfc
24    
25          (* Evict value from cache if it exists *)          (* Evict value from cache if it exists *)
26          val evict : SmlInfo.info -> unit          val evict : GP.info -> SmlInfo.info -> unit
27    
28          (* Check all values and evict those that depended on other          (* Check all values and evict those that depended on other
29           * meanwhile evicted ones. *)           * meanwhile evicted ones. *)
30          val cleanup : unit -> unit          val cleanup : GP.info -> unit
31    
32          val newTraversal : GG.group ->          val newTraversal : GG.group * bfcGetter ->
33              { group: GP.info -> env option,              { group: GP.info -> env option,
34                exports: (GP.info -> env option) SymbolMap.map }                exports: (GP.info -> env option) SymbolMap.map }
35    
# Line 30  Line 40 
40      end      end
41    
42      functor LinkFn (structure MachDepVC : MACHDEP_VC      functor LinkFn (structure MachDepVC : MACHDEP_VC
43                      val system_values : env ref) :> LINK = struct                      val system_values : env ref) :> LINK
44            where type bfc = MachDepVC.Binfile.bfContent =
45        struct
46    
47          structure BF = MachDepVC.Binfile          structure BF = MachDepVC.Binfile
48    
49            type bfc = BF.bfContent
50            type bfcGetter = SmlInfo.info -> bfc
51    
52          type bfun = GP.info -> E.dynenv -> E.dynenv          type bfun = GP.info -> E.dynenv -> E.dynenv
53    
54          datatype bnode =          datatype bnode =
55              B of bfun * bnode list              B of bfun * BinInfo.info * bnode list
56    
57          val stablemap = ref (StableMap.empty: bnode StableMap.map)          val stablemap = ref (StableMap.empty: bnode StableMap.map)
58    
# Line 51  Line 66 
66                                     DynamicEnv.empty))                                     DynamicEnv.empty))
67              handle DynamicEnv.Unbound => NONE              handle DynamicEnv.Unbound => NONE
68    
69          fun execute (bfc, de, error, descr) = let          fun exn_err (msg, error, descr, exn) = let
             fun exec () = let  
                 val e = BF.exec (bfc, de)  
             in  
                 E.dynamicPart e  
             end handle exn => let  
70                  fun ppb pps =                  fun ppb pps =
71                      (PP.add_newline pps;                      (PP.add_newline pps;
72                       PP.add_string pps (General.exnMessage exn);                       PP.add_string pps (General.exnMessage exn);
73                       PP.add_newline pps)                       PP.add_newline pps)
74              in              in
75                  error ("link-time error in " ^ descr) ppb;              error (concat [msg, " ", descr]) ppb;
76                  raise exn                  raise exn
77              end              end
78          in  
79            fun execute (bfc, de) =
80              case sysval (BF.exportPidOf bfc) of              case sysval (BF.exportPidOf bfc) of
81                  NONE => exec ()                  NONE => BF.exec (bfc, de)
82                | SOME de => de                | SOME de' => de'
         end  
83    
84          fun memoize thunk = let          fun memoize thunk = let
85              val r = ref (fn _ => raise Fail "Link:memoize")              val r = ref (fn _ => raise Fail "Link:memoize")
# Line 84  Line 94 
94              fn gp => !r gp              fn gp => !r gp
95          end          end
96    
97          fun registerGroup g = let          type smemo = E.dynenv * SmlInfo.info list
98              val GG.GROUP { grouppath, kind, sublibs, ... } = g  
99              val visited = ref SrcPathSet.empty          val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)
100              fun registerStableLib (GG.GROUP { exports, ... }) = let  
101                  val localmap = ref StableMap.empty          fun evict gp i = let
102                  fun link (i, e) = let              fun check () =
103                    case SmlInfo.sh_mode i of
104                        Sharing.SHARE true =>
105                            SmlInfo.error gp i EM.WARN
106                              (concat ["sharing for ",
107                                       SmlInfo.descr i,
108                                       " may be lost"])
109                              EM.nullErrorBody
110                      | _ =>  ()
111            in
112                (smlmap := #1 (SmlInfoMap.remove (!smlmap, i))
113                 before check ())
114                handle LibBase.NotFound => ()
115            end
116    
117            fun cleanup gp = let
118                val visited = ref SmlInfoSet.empty
119                fun visit i =
120                    if SmlInfoSet.member (!visited, i) then true
121                    else
122                        case SmlInfoMap.find (!smlmap, i) of
123                            NONE => false
124                          | SOME (_, l) => let
125                                val bl = map visit l
126                                val b = List.all (fn x => x) bl
127                            in
128                                if b then
129                                    (visited := SmlInfoSet.add (!visited, i);
130                                     true)
131                                else (evict gp i; false)
132                            end
133            in
134                app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))
135            end
136    
137            fun prim2dyn p (gp: GP.info) =
138                E.dynamicPart (Primitive.env (#primconf (#param gp)) p)
139    
140            fun getPerv (gp: GP.info) = E.dynamicPart (#pervasive (#param gp))
141    
142            fun link_stable (i, e) = let
143                      val stable = BinInfo.stablename i                      val stable = BinInfo.stablename i
144                      val os = BinInfo.offset i                      val os = BinInfo.offset i
145                      val descr = BinInfo.describe i                      val descr = BinInfo.describe i
146                      val _ = Say.vsay ["[linking with ", descr, "]\n"]                      val _ = Say.vsay ["[linking with ", descr, "]\n"]
147                      fun work s =              val error = BinInfo.error i EM.COMPLAIN
148            in
149                let fun work s =
150                          (Seek.seek (s, os);                          (Seek.seek (s, os);
151                           (* We can use an empty static env because no                           (* We can use an empty static env because no
152                            * unpickling will be done. *)                            * unpickling will be done. *)
153                           BF.read { stream = s, name = descr,                   BF.read { stream = s, name = descr, senv = emptyStatic })
154                                     senv = emptyStatic })                  val bfc =
155                      (* We handle no errors here because failure to load a                      SafeIO.perform { openIt = fn () => BinIO.openIn stable,
                      * stable library module is serious and should lead to  
                      * a complete abort (which it does if we don't do something  
                      * about it). *)  
                     val bfc = SafeIO.perform { openIt =  
                                                   fn () => BinIO.openIn stable,  
156                                                 closeIt = BinIO.closeIn,                                                 closeIt = BinIO.closeIn,
157                                                 work = work,                                                 work = work,
158                                                 cleanup = fn () => () }                                                 cleanup = fn () => () }
159                        handle exn =>
160                            exn_err ("unable to load library module",
161                                     error, descr, exn)
162                      val epid = BF.exportPidOf bfc                      val epid = BF.exportPidOf bfc
163                  in                  in
164                      execute (bfc, e, BinInfo.error i EM.COMPLAIN, descr)                  execute (bfc, e)
165                    handle exn => exn_err ("link-time exception in library code",
166                                           error, descr, exn)
167                end
168                  end                  end
169    
170            fun link_sml (gp, i, getBFC, getE, snl) = let
171                fun fresh () = let
172                    val bfc = getBFC i
173                in
174                    case getE gp of
175                        NONE => NONE
176                      | SOME e =>
177                            (SOME (execute (bfc, e))
178                             handle exn =>
179                                 exn_err ("link-time exception in user program",
180                                          SmlInfo.error gp i EM.COMPLAIN,
181                                          SmlInfo.descr i,
182                                          exn))
183                end handle _ => NONE
184            in
185                case SmlInfo.sh_mode i of
186                    Sharing.SHARE _ =>
187                        (case SmlInfoMap.find (!smlmap, i) of
188                             NONE =>
189                                 (case fresh () of
190                                      NONE => NONE
191                                    | SOME de => let
192                                          val m = (de, snl)
193                                      in
194                                          smlmap :=
195                                            SmlInfoMap.insert (!smlmap, i, m);
196                                          SOME de
197                                      end)
198                           | SOME (de, _) => SOME de)
199                  | Sharing.DONTSHARE => (evict gp i; fresh ())
200            end
201    
202            fun registerGroup g = let
203                val GG.GROUP { grouppath, kind, sublibs, ... } = g
204                val visited = ref SrcPathSet.empty
205                fun registerStableLib (GG.GROUP { exports, ... }) = let
206                    val localmap = ref StableMap.empty
207                  fun bn (DG.PNODE p) =                  fun bn (DG.PNODE p) =
208                      B (fn (gp: GP.info) => fn _ =>                      (fn gp => fn _ => prim2dyn p gp, NONE)
                            E.dynamicPart (Primitive.env  
                                           (#primconf (#param gp)) p),  
                        [])  
209                    | bn (DG.BNODE n) = let                    | bn (DG.BNODE n) = let
210                          val { bininfo = i, localimports, globalimports } = n                          val { bininfo = i, localimports, globalimports } = n
211                          fun new () = let                          fun new () = let
212                              val e0 = (fn (gp: GP.info) =>                              val e0 = (getPerv, [])
213                                          E.dynamicPart (#pervasive (#param gp)),                              fun join ((f, NONE), (e, l)) =
                                       [])  
                             fun join (B (f, []), (e, l)) =  
214                                  (fn gp => DE.atop (f gp emptyDyn, e gp), l)                                  (fn gp => DE.atop (f gp emptyDyn, e gp), l)
215                                | join (b, (e, l)) = (e, b :: l)                                | join ((f, SOME (i, l')), (e, l)) =
216                                    (e, B (f, i, l') :: l)
217                              val ge = foldl join e0 (map fbn globalimports)                              val ge = foldl join e0 (map fbn globalimports)
218                              val le = foldl join ge (map bn localimports)                              val le = foldl join ge (map bn localimports)
219                          in                          in
220                              case (BinInfo.sh_mode i, le) of                              case (BinInfo.sh_mode i, le) of
221                                  (Sharing.SHARE _, (e, [])) => let                                  (Sharing.SHARE _, (e, [])) => let
222                                      fun thunk gp = link (i, e gp)                                      fun thunk gp = link_stable (i, e gp)
223                                      val m_thunk = memoize thunk                                      val m_thunk = memoize thunk
224                                  in                                  in
225                                      B (fn gp => fn _ => m_thunk gp, [])                                      (fn gp => fn _ => m_thunk gp, NONE)
226                                  end                                  end
227                                | (Sharing.SHARE _, _) =>                                | (Sharing.SHARE _, _) =>
228                                  EM.impossible "Link: sh_mode inconsistent"                                  EM.impossible "Link: sh_mode inconsistent"
229                                    | (Sharing.DONTSHARE, (e, l)) =>                                    | (Sharing.DONTSHARE, (e, l)) =>
230                                  B (fn gp => fn e' =>                                  (fn gp => fn e' =>
231                                       link (i, (DE.atop (e', e gp))),                                     link_stable (i, (DE.atop (e', e gp))),
232                                     l)                                   SOME (i, l))
233                          end                          end
234                      in                      in
235                          case StableMap.find (!stablemap, i) of                          case StableMap.find (!stablemap, i) of
236                              SOME x => x                              SOME (B (f, i, [])) =>
237                                    (case BinInfo.sh_mode i of
238                                         Sharing.DONTSHARE => (f, SOME (i, []))
239                                       | _ => (f, NONE))
240                              | SOME (B (f, i, l)) => (f, SOME (i, l))
241                            | NONE =>                            | NONE =>
242                                  (case StableMap.find (!localmap, i) of                                  (case StableMap.find (!localmap, i) of
243                                       SOME x => x                                       SOME x => x
# Line 164  Line 255 
255                  fun sbn (DG.SB_SNODE n) =                  fun sbn (DG.SB_SNODE n) =
256                      EM.impossible "Link:SNODE in stable lib"                      EM.impossible "Link:SNODE in stable lib"
257                    | sbn (DG.SB_BNODE (DG.PNODE _, _)) = ()                    | sbn (DG.SB_BNODE (DG.PNODE _, _)) = ()
258                    | sbn (DG.SB_BNODE (n as DG.BNODE b, _)) = let                    | sbn (DG.SB_BNODE (n as DG.BNODE { bininfo, ... }, _)) = let
259                          val x = bn n                          val b as B (_, i, _) =
260                          val i = #bininfo b                              case bn n of
261                                    (f, NONE) => B (f, bininfo, [])
262                                  | (f, SOME (i, l)) => B (f, i, l)
263                      in                      in
264                          stablemap := StableMap.insert (!stablemap, i, x)                          stablemap := StableMap.insert (!stablemap, i, b)
265                      end                      end
266    
267                  fun fsbn (_, n) = sbn n                  fun fsbn (_, n) = sbn n
# Line 185  Line 278 
278                      | _ => ())                      | _ => ())
279          end          end
280    
281          type smemo = E.dynenv * SmlInfo.info list          fun newTraversal (group as GG.GROUP { exports, ... }, getBFC) = let
282                val _ = registerGroup group
283    
284          val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)              val l_stablemap = ref StableMap.empty
285                val l_smlmap = ref SmlInfoMap.empty
286    
287          fun evict i = (smlmap := #1 (SmlInfoMap.remove (!smlmap, i)))              fun bnode (B (f, i, l)) =
288              handle LibBase.NotFound => ()                  case StableMap.find (!l_stablemap, i) of
289                        SOME th => th
290                      | NONE => let
291                            val fl = map bnode l
292                            fun th gp = let
293                                fun add (t, e) = DE.atop (t gp, e)
294                            in
295                                f gp (foldl add emptyDyn fl)
296                            end
297                            val m_th = memoize th
298                        in
299                            l_stablemap :=
300                              StableMap.insert (!l_stablemap, i, m_th);
301                            m_th
302                        end
303    
304          fun cleanup () = let              fun sbn (DG.SB_BNODE (DG.PNODE p, _)) = (SOME o prim2dyn p, [])
305              val visited = ref SmlInfoSet.empty                | sbn (DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)) = let
306              fun visit i =                      val b = valOf (StableMap.find (!stablemap, bininfo))
307                  if SmlInfoSet.member (!visited, i) then true                      fun th gp =
308                  else                          SOME (bnode b gp)
309                      case SmlInfoMap.find (!smlmap, i) of                          handle exn => NONE
                         NONE => false  
                       | SOME (_, l) => let  
                             val bl = map visit l  
                             val b = List.all (fn x => x) bl  
310                          in                          in
311                              if b then                      (th, [])
                                 (visited := SmlInfoSet.add (!visited, i);  
                                  true)  
                             else (evict i; false)  
312                          end                          end
313                  | sbn (DG.SB_SNODE n) = sn n
314    
315                and sn (DG.SNODE n) = let
316                    val { smlinfo = i, localimports, globalimports } = n
317          in          in
318              app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))                  case SmlInfoMap.find (!l_smlmap, i) of
319                        SOME th => (th, [i])
320                      | NONE => let
321                            fun atop (NONE, _) = NONE
322                              | atop (_, NONE) = NONE
323                              | atop (SOME e, SOME e') = SOME (DE.atop (e, e'))
324                            fun add ((f, l), (f', l')) =
325                                (fn gp => atop (f gp, f' gp), l @ l')
326                            val gi = foldl add (SOME o getPerv, [])
327                                               (map fsbn globalimports)
328                            val (getE, snl) = foldl add gi (map sn localimports)
329                            fun thunk gp = link_sml (gp, i, getBFC, getE, snl)
330                            val m_thunk = memoize thunk
331                        in
332                            l_smlmap := SmlInfoMap.insert (!l_smlmap, i, m_thunk);
333                            (m_thunk, [i])
334                        end
335          end          end
336    
337          fun newTraversal group = let              and fsbn (_, n) = sbn n
338    
339                fun impexp (n, _) = #1 (fsbn n)
340    
341                val exports' = SymbolMap.map impexp exports
342    
343                fun group' gp = let
344                    fun one (_, NONE) = NONE
345                      | one (f, SOME e) =
346                        (case f gp of
347                             NONE => NONE
348                           | SOME e' => SOME (DE.atop (e', e)))
349                in
350                    SymbolMap.foldl one (SOME emptyDyn) exports'
351                end
352          in          in
353              Dummy.f ()              { exports = exports', group = group' }
354          end          end
355    
356          fun reset () = (stablemap := StableMap.empty;          fun reset () = (stablemap := StableMap.empty;

Legend:
Removed from v.399  
changed lines
  Added in v.404

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