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 400, Thu Aug 26 16:23:37 1999 UTC
# Line 10  Line 10 
10      type env = E.dynenv      type env = E.dynenv
11  in  in
12      signature LINK = sig      signature LINK = sig
         val registerGroup : GG.group -> unit  
   
13          (* Evict value from cache if it exists *)          (* Evict value from cache if it exists *)
14          val evict : SmlInfo.info -> unit          val evict : GP.info -> SmlInfo.info -> unit
15    
16          (* Check all values and evict those that depended on other          (* Check all values and evict those that depended on other
17           * meanwhile evicted ones. *)           * meanwhile evicted ones. *)
18          val cleanup : unit -> unit          val cleanup : GP.info -> unit
19    
20          val newTraversal : GG.group ->          val newTraversal : GG.group ->
21              { group: GP.info -> env option,              { group: GP.info -> env option,
# Line 30  Line 28 
28      end      end
29    
30      functor LinkFn (structure MachDepVC : MACHDEP_VC      functor LinkFn (structure MachDepVC : MACHDEP_VC
31                        val getBFC : SmlInfo.info -> MachDepVC.Binfile.bfContent
32                      val system_values : env ref) :> LINK = struct                      val system_values : env ref) :> LINK = struct
33    
34          structure BF = MachDepVC.Binfile          structure BF = MachDepVC.Binfile
# Line 37  Line 36 
36          type bfun = GP.info -> E.dynenv -> E.dynenv          type bfun = GP.info -> E.dynenv -> E.dynenv
37    
38          datatype bnode =          datatype bnode =
39              B of bfun * bnode list              B of bfun * BinInfo.info * bnode list
40    
41          val stablemap = ref (StableMap.empty: bnode StableMap.map)          val stablemap = ref (StableMap.empty: bnode StableMap.map)
42    
# Line 51  Line 50 
50                                     DynamicEnv.empty))                                     DynamicEnv.empty))
51              handle DynamicEnv.Unbound => NONE              handle DynamicEnv.Unbound => NONE
52    
53          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  
54                  fun ppb pps =                  fun ppb pps =
55                      (PP.add_newline pps;                      (PP.add_newline pps;
56                       PP.add_string pps (General.exnMessage exn);                       PP.add_string pps (General.exnMessage exn);
57                       PP.add_newline pps)                       PP.add_newline pps)
58              in              in
59                  error ("link-time error in " ^ descr) ppb;              error (concat [msg, " ", descr]) ppb;
60                  raise exn                  raise exn
61              end              end
62    
63            fun execute (bfc, de) = let
64                fun exec () = E.dynamicPart (BF.exec (bfc, de))
65          in          in
66              case sysval (BF.exportPidOf bfc) of              case sysval (BF.exportPidOf bfc) of
67                  NONE => exec ()                  NONE => exec ()
# Line 84  Line 81 
81              fn gp => !r gp              fn gp => !r gp
82          end          end
83    
84          fun registerGroup g = let          type smemo = E.dynenv * SmlInfo.info list
85              val GG.GROUP { grouppath, kind, sublibs, ... } = g  
86              val visited = ref SrcPathSet.empty          val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)
87              fun registerStableLib (GG.GROUP { exports, ... }) = let  
88                  val localmap = ref StableMap.empty          fun evict gp i = let
89                  fun link (i, e) = let              fun check () =
90                    case SmlInfo.sh_mode i of
91                        Sharing.SHARE true =>
92                            SmlInfo.error gp i EM.WARN
93                              (concat ["sharing for ",
94                                       SmlInfo.descr i,
95                                       " may be lost"])
96                              EM.nullErrorBody
97                      | _ =>  ()
98            in
99                (smlmap := #1 (SmlInfoMap.remove (!smlmap, i))
100                 before check ())
101                handle LibBase.NotFound => ()
102            end
103    
104            fun cleanup gp = let
105                val visited = ref SmlInfoSet.empty
106                fun visit i =
107                    if SmlInfoSet.member (!visited, i) then true
108                    else
109                        case SmlInfoMap.find (!smlmap, i) of
110                            NONE => false
111                          | SOME (_, l) => let
112                                val bl = map visit l
113                                val b = List.all (fn x => x) bl
114                            in
115                                if b then
116                                    (visited := SmlInfoSet.add (!visited, i);
117                                     true)
118                                else (evict gp i; false)
119                            end
120            in
121                app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))
122            end
123    
124            fun prim2dyn p (gp: GP.info) =
125                E.dynamicPart (Primitive.env (#primconf (#param gp)) p)
126    
127            fun getPerv (gp: GP.info) = E.dynamicPart (#pervasive (#param gp))
128    
129            fun link_stable (i, e) = let
130                      val stable = BinInfo.stablename i                      val stable = BinInfo.stablename i
131                      val os = BinInfo.offset i                      val os = BinInfo.offset i
132                      val descr = BinInfo.describe i                      val descr = BinInfo.describe i
133                      val _ = Say.vsay ["[linking with ", descr, "]\n"]                      val _ = Say.vsay ["[linking with ", descr, "]\n"]
134                      fun work s =              val error = BinInfo.error i EM.COMPLAIN
135            in
136                let fun work s =
137                          (Seek.seek (s, os);                          (Seek.seek (s, os);
138                           (* We can use an empty static env because no                           (* We can use an empty static env because no
139                            * unpickling will be done. *)                            * unpickling will be done. *)
140                           BF.read { stream = s, name = descr,                   BF.read { stream = s, name = descr, senv = emptyStatic })
141                                     senv = emptyStatic })                  val bfc =
142                      (* 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,  
143                                                 closeIt = BinIO.closeIn,                                                 closeIt = BinIO.closeIn,
144                                                 work = work,                                                 work = work,
145                                                 cleanup = fn () => () }                                                 cleanup = fn () => () }
146                        handle exn =>
147                            exn_err ("unable to load library module",
148                                     error, descr, exn)
149                      val epid = BF.exportPidOf bfc                      val epid = BF.exportPidOf bfc
150                  in                  in
151                      execute (bfc, e, BinInfo.error i EM.COMPLAIN, descr)                  execute (bfc, e)
152                    handle exn => exn_err ("link-time exception in library code",
153                                           error, descr, exn)
154                end
155                  end                  end
156    
157            fun link_sml (gp, i, getE, snl) = let
158                fun fresh () = let
159                    val bfc = getBFC i
160                in
161                    case getE gp of
162                        NONE => NONE
163                      | SOME e =>
164                            (SOME (execute (bfc, e))
165                             handle exn =>
166                                 exn_err ("link-time exception in user program",
167                                          SmlInfo.error gp i EM.COMPLAIN,
168                                          SmlInfo.descr i,
169                                          exn))
170                end handle _ => NONE
171            in
172                case SmlInfo.sh_mode i of
173                    Sharing.SHARE _ =>
174                        (case SmlInfoMap.find (!smlmap, i) of
175                             NONE =>
176                                 (case fresh () of
177                                      NONE => NONE
178                                    | SOME de => let
179                                          val m = (de, snl)
180                                      in
181                                          smlmap :=
182                                            SmlInfoMap.insert (!smlmap, i, m);
183                                          SOME de
184                                      end)
185                           | SOME (de, _) => SOME de)
186                  | Sharing.DONTSHARE => (evict gp i; fresh ())
187            end
188    
189            fun registerGroup g = let
190                val GG.GROUP { grouppath, kind, sublibs, ... } = g
191                val visited = ref SrcPathSet.empty
192                fun registerStableLib (GG.GROUP { exports, ... }) = let
193                    val localmap = ref StableMap.empty
194                  fun bn (DG.PNODE p) =                  fun bn (DG.PNODE p) =
195                      B (fn (gp: GP.info) => fn _ =>                      (fn gp => fn _ => prim2dyn p gp, NONE)
                            E.dynamicPart (Primitive.env  
                                           (#primconf (#param gp)) p),  
                        [])  
196                    | bn (DG.BNODE n) = let                    | bn (DG.BNODE n) = let
197                          val { bininfo = i, localimports, globalimports } = n                          val { bininfo = i, localimports, globalimports } = n
198                          fun new () = let                          fun new () = let
199                              val e0 = (fn (gp: GP.info) =>                              val e0 = (getPerv, [])
200                                          E.dynamicPart (#pervasive (#param gp)),                              fun join ((f, NONE), (e, l)) =
                                       [])  
                             fun join (B (f, []), (e, l)) =  
201                                  (fn gp => DE.atop (f gp emptyDyn, e gp), l)                                  (fn gp => DE.atop (f gp emptyDyn, e gp), l)
202                                | join (b, (e, l)) = (e, b :: l)                                | join ((f, SOME (i, l')), (e, l)) =
203                                    (e, B (f, i, l') :: l)
204                              val ge = foldl join e0 (map fbn globalimports)                              val ge = foldl join e0 (map fbn globalimports)
205                              val le = foldl join ge (map bn localimports)                              val le = foldl join ge (map bn localimports)
206                          in                          in
207                              case (BinInfo.sh_mode i, le) of                              case (BinInfo.sh_mode i, le) of
208                                  (Sharing.SHARE _, (e, [])) => let                                  (Sharing.SHARE _, (e, [])) => let
209                                      fun thunk gp = link (i, e gp)                                      fun thunk gp = link_stable (i, e gp)
210                                      val m_thunk = memoize thunk                                      val m_thunk = memoize thunk
211                                  in                                  in
212                                      B (fn gp => fn _ => m_thunk gp, [])                                      (fn gp => fn _ => m_thunk gp, NONE)
213                                  end                                  end
214                                | (Sharing.SHARE _, _) =>                                | (Sharing.SHARE _, _) =>
215                                  EM.impossible "Link: sh_mode inconsistent"                                  EM.impossible "Link: sh_mode inconsistent"
216                                    | (Sharing.DONTSHARE, (e, l)) =>                                    | (Sharing.DONTSHARE, (e, l)) =>
217                                  B (fn gp => fn e' =>                                  (fn gp => fn e' =>
218                                       link (i, (DE.atop (e', e gp))),                                     link_stable (i, (DE.atop (e', e gp))),
219                                     l)                                   SOME (i, l))
220                          end                          end
221                      in                      in
222                          case StableMap.find (!stablemap, i) of                          case StableMap.find (!stablemap, i) of
223                              SOME x => x                              SOME (B (f, i, l)) => (f, SOME (i, l))
224                            | NONE =>                            | NONE =>
225                                  (case StableMap.find (!localmap, i) of                                  (case StableMap.find (!localmap, i) of
226                                       SOME x => x                                       SOME x => x
# Line 164  Line 238 
238                  fun sbn (DG.SB_SNODE n) =                  fun sbn (DG.SB_SNODE n) =
239                      EM.impossible "Link:SNODE in stable lib"                      EM.impossible "Link:SNODE in stable lib"
240                    | sbn (DG.SB_BNODE (DG.PNODE _, _)) = ()                    | sbn (DG.SB_BNODE (DG.PNODE _, _)) = ()
241                    | sbn (DG.SB_BNODE (n as DG.BNODE b, _)) = let                    | sbn (DG.SB_BNODE (n as DG.BNODE { bininfo, ... }, _)) = let
242                          val x = bn n                          val b as B (_, i, _) =
243                          val i = #bininfo b                              case bn n of
244                                    (f, NONE) => B (f, bininfo, [])
245                                  | (f, SOME (i, l)) => B (f, i, l)
246                      in                      in
247                          stablemap := StableMap.insert (!stablemap, i, x)                          stablemap := StableMap.insert (!stablemap, i, b)
248                      end                      end
249    
250                  fun fsbn (_, n) = sbn n                  fun fsbn (_, n) = sbn n
# Line 185  Line 261 
261                      | _ => ())                      | _ => ())
262          end          end
263    
264          type smemo = E.dynenv * SmlInfo.info list          fun newTraversal (group as GG.GROUP { exports, ... }) = let
265                val _ = registerGroup group
266    
267          val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)              val l_stablemap = ref StableMap.empty
268                val l_smlmap = ref SmlInfoMap.empty
269    
270          fun evict i = (smlmap := #1 (SmlInfoMap.remove (!smlmap, i)))              fun bnode (B (f, i, l)) =
271              handle LibBase.NotFound => ()                  case StableMap.find (!l_stablemap, i) of
272                        SOME th => th
273                      | NONE => let
274                            val fl = map bnode l
275                            fun th gp = let
276                                fun add (t, e) = DE.atop (t gp, e)
277                            in
278                                f gp (foldl add emptyDyn fl)
279                            end
280                            val m_th = memoize th
281                        in
282                            l_stablemap :=
283                              StableMap.insert (!l_stablemap, i, m_th);
284                            m_th
285                        end
286    
287          fun cleanup () = let              fun sbn (DG.SB_BNODE (DG.PNODE p, _)) = (SOME o prim2dyn p, [])
288              val visited = ref SmlInfoSet.empty                | sbn (DG.SB_BNODE (DG.BNODE { bininfo, ... }, _)) = let
289              fun visit i =                      val b = valOf (StableMap.find (!stablemap, bininfo))
290                  if SmlInfoSet.member (!visited, i) then true                      fun th gp =
291                  else                          SOME (bnode b gp)
292                      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  
293                          in                          in
294                              if b then                      (th, [])
                                 (visited := SmlInfoSet.add (!visited, i);  
                                  true)  
                             else (evict i; false)  
295                          end                          end
296                  | sbn (DG.SB_SNODE n) = sn n
297    
298                and sn (DG.SNODE n) = let
299                    val { smlinfo = i, localimports, globalimports } = n
300          in          in
301              app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))                  case SmlInfoMap.find (!l_smlmap, i) of
302                        SOME th => (th, [i])
303                      | NONE => let
304                            fun atop (NONE, _) = NONE
305                              | atop (_, NONE) = NONE
306                              | atop (SOME e, SOME e') = SOME (DE.atop (e, e'))
307                            fun add ((f, l), (f', l')) =
308                                (fn gp => atop (f gp, f' gp), l @ l')
309                            val gi = foldl add (SOME o getPerv, [])
310                                               (map fsbn globalimports)
311                            val (getE, snl) = foldl add gi (map sn localimports)
312                            fun thunk gp = link_sml (gp, i, getE, snl)
313                            val m_thunk = memoize thunk
314                        in
315                            l_smlmap := SmlInfoMap.insert (!l_smlmap, i, m_thunk);
316                            (m_thunk, [i])
317          end          end
318                end
319    
320                and fsbn (_, n) = sbn n
321    
322          fun newTraversal group = let              fun impexp (n, _) = #1 (fsbn n)
323    
324                val exports' = SymbolMap.map impexp exports
325    
326                fun group' gp = let
327                    fun one (_, NONE) = NONE
328                      | one (f, SOME e) =
329                        (case f gp of
330                             NONE => NONE
331                           | SOME e' => SOME (DE.atop (e', e)))
332                in
333                    SymbolMap.foldl one (SOME emptyDyn) exports'
334                end
335          in          in
336              Dummy.f ()              { exports = exports', group = group' }
337          end          end
338    
339          fun reset () = (stablemap := StableMap.empty;          fun reset () = (stablemap := StableMap.empty;

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

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