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 537, Fri Feb 18 17:20:16 2000 UTC revision 569, Tue Mar 7 04:01:07 2000 UTC
# Line 36  Line 36 
36              { group: GP.info -> env option,              { group: GP.info -> env option,
37                exports: (GP.info -> env option) SymbolMap.map }                exports: (GP.info -> env option) SymbolMap.map }
38    
         val sysval : GenericVC.PersStamps.persstamp option -> env option  
   
39          (* discard persistent state *)          (* discard persistent state *)
40          val reset : unit -> unit          val reset : unit -> unit
41      end      end
# Line 45  Line 43 
43      functor LinkFn (structure MachDepVC : MACHDEP_VC      functor LinkFn (structure MachDepVC : MACHDEP_VC
44                      structure BFC : BFC                      structure BFC : BFC
45                      sharing type MachDepVC.Binfile.bfContent = BFC.bfc                      sharing type MachDepVC.Binfile.bfContent = BFC.bfc
46                      val system_values : env ref) :> LINK                      val system_values : env SrcPathMap.map ref) :> LINK
47          where type bfc = BFC.bfc =          where type bfc = BFC.bfc =
48      struct      struct
49    
# Line 61  Line 59 
59    
60          val stablemap = ref (StableMap.empty: bnode StableMap.map)          val stablemap = ref (StableMap.empty: bnode StableMap.map)
61    
         val emptyStatic = E.staticPart E.emptyEnv  
         val emptyDyn = E.dynamicPart E.emptyEnv  
   
         fun sysval NONE = NONE  
           | sysval (SOME pid) =  
             SOME (DynamicEnv.bind (pid,  
                                    DynamicEnv.look (!system_values) pid,  
                                    DynamicEnv.empty))  
             handle DynamicEnv.Unbound => NONE  
   
         fun exn_err (msg, error, descr, exn) = let  
             fun ppb pps =  
                 (PP.add_newline pps;  
                  PP.add_string pps (General.exnMessage exn);  
                  PP.add_newline pps)  
         in  
             error (concat [msg, " ", descr]) ppb;  
             raise exn  
         end  
   
         (* We invoke mk_de here and only if we don't have the value  
          * available as a sysval.  This saves the (unnecessary) traversal  
          * in the stable case. (Normally all sysval entries are from  
          * stable libraries.) *)  
         fun execute (bfc, mk_de, gp: GP.info) =  
             case sysval (BF.exportPidOf bfc) of  
                 NONE =>  
                     BF.exec (bfc,  
                              DE.atop (mk_de gp,  
                                       BE.dynamicPart (#corenv (#param gp))))  
               | SOME de' => de'  
   
62          type smemo = E.dynenv * SmlInfo.info list          type smemo = E.dynenv * SmlInfo.info list
63    
64          val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)          val smlmap = ref (SmlInfoMap.empty: smemo SmlInfoMap.map)
65    
66            val emptyStatic = E.staticPart E.emptyEnv
67            val emptyDyn = E.dynamicPart E.emptyEnv
68    
69          fun evict gp i = let          fun evict gp i = let
70              fun check () =              fun check () =
71                  case SmlInfo.sh_mode i of                  case SmlInfo.sh_mode i of
# Line 136  Line 105 
105              app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))              app (visit o #1) (SmlInfoMap.listItemsi (!smlmap))
106          end          end
107    
108            fun newTraversal (group, getBFC) = let
109    
110                val GG.GROUP { exports, grouppath, ... } = group
111    
112                fun exn_err (msg, error, descr, exn) = let
113                    fun ppb pps =
114                        (PP.add_newline pps;
115                         PP.add_string pps (General.exnMessage exn);
116                         PP.add_newline pps)
117                in
118                    error (concat [msg, " ", descr]) ppb;
119                    raise exn
120                end
121    
122                (* We invoke mk_de here and only if we don't have the value
123                 * available as a sysval.  This saves the (unnecessary) traversal
124                 * in the stable case. (Normally all sysval entries are from
125                 * stable libraries.) *)
126                fun execute sysval (bfc, mk_de, gp: GP.info) =
127                    case sysval (BF.exportPidOf bfc) of
128                        NONE =>
129                            BF.exec (bfc,
130                                     DE.atop (mk_de gp,
131                                              BE.dynamicPart(#corenv (#param gp))))
132                      | SOME de' => de'
133    
134          (* Construction of the environment is delayed until we are          (* Construction of the environment is delayed until we are
135           * sure we really, really need it.  This way we spare ourselves               * sure we really REALLY need it.  This way we spare ourselves
136           * the trouble of doing the ancestor traversal iff we               * the trouble of doing the ancestor traversal if we
137           * end up finding out we already have the value in sysVal. *)           * end up finding out we already have the value in sysVal. *)
138          fun link_stable (i, mk_e, gp) = let              fun link_stable sysval (i, mk_e, gp) = let
139              val stable = BinInfo.stablename i              val stable = BinInfo.stablename i
140              val os = BinInfo.offset i              val os = BinInfo.offset i
141              val descr = BinInfo.describe i              val descr = BinInfo.describe i
142              val error = BinInfo.error i EM.COMPLAIN              val error = BinInfo.error i EM.COMPLAIN
143              val bfc =                  val bfc = BFC.getStable { stable = stable, offset = os,
144                  BFC.getStable { stable = stable, offset = os, descr = descr }                                            descr = descr }
145                  handle exn => exn_err ("unable to load library module",                  handle exn => exn_err ("unable to load library module",
146                                         error, descr, exn)                                         error, descr, exn)
147          in          in
148              execute (bfc, mk_e, gp)                  execute sysval (bfc, mk_e, gp)
149              handle exn => exn_err ("link-time exception in library code",                  handle exn =>
150                        exn_err ("link-time exception in library code",
151                                     error, descr, exn)                                     error, descr, exn)
152          end          end
153    
# Line 162  Line 158 
158                  case getE gp of                  case getE gp of
159                      NONE => NONE                      NONE => NONE
160                    | SOME e =>                    | SOME e =>
161                          (SOME (execute (bfc, fn _ => e, gp))                              (SOME (execute (fn _ => NONE) (bfc, fn _ => e, gp))
162                           handle exn =>                           handle exn =>
163                               exn_err ("link-time exception in user program",                               exn_err ("link-time exception in user program",
164                                        SmlInfo.error gp i EM.COMPLAIN,                                        SmlInfo.error gp i EM.COMPLAIN,
# Line 187  Line 183 
183                | Sharing.DONTSHARE => (evict gp i; fresh ())                | Sharing.DONTSHARE => (evict gp i; fresh ())
184          end          end
185    
         fun registerGroup g = let  
186              val visited = ref SrcPathSet.empty              val visited = ref SrcPathSet.empty
187              fun registerGroup' g = let  
188                fun registerGroup g = let
189                  val GG.GROUP { grouppath, kind, sublibs, ... } = g                  val GG.GROUP { grouppath, kind, sublibs, ... } = g
190                  fun registerStableLib (GG.GROUP { exports, ... }) = let                  fun registerStableLib (GG.GROUP sg) = let
191                        val { exports, grouppath = sgp, ... } = sg
192                        val sysvals =
193                            let val (m', e) =
194                                SrcPathMap.remove (!system_values, sgp)
195                            in system_values := m'; e
196                            end handle LibBase.NotFound => emptyDyn
197    
198                        fun sv (SOME pid) =
199                            (SOME (DE.bind (pid, DE.look sysvals pid, emptyDyn))
200                             handle DE.Unbound => NONE)
201                          | sv _ = NONE
202    
203                      val localmap = ref StableMap.empty                      val localmap = ref StableMap.empty
204                      fun bn (DG.BNODE n) = let                      fun bn (DG.BNODE n) = let
205                              val { bininfo = i, localimports, globalimports } =                          val { bininfo = i, localimports, globalimports } = n
                                 n  
206                              fun new () = let                              fun new () = let
207                                  val e0 = (fn _ => emptyDyn, [])                                  val e0 = (fn _ => emptyDyn, [])
208                                  fun join ((f, NONE), (e, l)) =                                  fun join ((f, NONE), (e, l)) =
# Line 207  Line 214 
214                              in                              in
215                                  case (BinInfo.sh_mode i, le) of                                  case (BinInfo.sh_mode i, le) of
216                                      (Sharing.SHARE _, (e, [])) => let                                      (Sharing.SHARE _, (e, [])) => let
217                                          fun thunk gp =                                      fun thunk gp = link_stable sv (i, e, gp)
                                             link_stable (i, e, gp)  
218                                          val m_thunk = Memoize.memoize thunk                                          val m_thunk = Memoize.memoize thunk
219                                      in                                      in
220                                          (fn gp => fn _ => m_thunk gp, NONE)                                          (fn gp => fn _ => m_thunk gp, NONE)
# Line 217  Line 223 
223                                      EM.impossible "Link: sh_mode inconsistent"                                      EM.impossible "Link: sh_mode inconsistent"
224                                    | (Sharing.DONTSHARE, (e, l)) =>                                    | (Sharing.DONTSHARE, (e, l)) =>
225                                      (fn gp => fn e' =>                                      (fn gp => fn e' =>
226                                       link_stable (i,                                   link_stable sv
227                                                    fn gp => DE.atop (e', e gp),                                      (i, fn gp => DE.atop (e', e gp), gp),
                                                   gp),  
228                                       SOME (i, l))                                       SOME (i, l))
229                              end                              end
230                          in                          in
# Line 260  Line 265 
265              in              in
266                  if SrcPathSet.member (!visited, grouppath) then ()                  if SrcPathSet.member (!visited, grouppath) then ()
267                  else (visited := SrcPathSet.add (!visited, grouppath);                  else (visited := SrcPathSet.add (!visited, grouppath);
268                        app (registerGroup' o #2) sublibs;                        app (registerGroup o #2) sublibs;
269                        case kind of                        case kind of
270                            GG.STABLELIB _ => registerStableLib g                            GG.STABLELIB _ => registerStableLib g
271                          | _ => ())                          | _ => ())
272              end              end
         in  
             registerGroup' g  
         end  
   
         fun newTraversal (group as GG.GROUP { exports, ... }, getBFC) = let  
273    
274              val _ = registerGroup group              val _ = registerGroup group
275    

Legend:
Removed from v.537  
changed lines
  Added in v.569

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