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/bootstrap/btcompile.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/bootstrap/btcompile.sml

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

revision 537, Fri Feb 18 17:20:16 2000 UTC revision 592, Mon Apr 3 07:04:12 2000 UTC
# Line 6  Line 6 
6   *   *
7   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
8   *)   *)
9  functor BootstrapCompileFn (structure MachDepVC : MACHDEP_VC  local
10        structure EM = GenericVC.ErrorMsg
11        structure E = GenericVC.Environment
12        structure SE = GenericVC.StaticEnv
13        structure PS = GenericVC.PersStamps
14        structure GG = GroupGraph
15        structure DG = DependencyGraph
16    in
17    functor BootstrapCompileFn
18                (structure MachDepVC : MACHDEP_VC
19                              val os : SMLofNJ.SysInfo.os_kind                              val os : SMLofNJ.SysInfo.os_kind
20                              val load_plugin : string -> bool) :> sig               val load_plugin : SrcPath.context -> string -> bool) :> sig
21      val make' : string option -> bool      val make' : string option -> bool
22      val make : unit -> bool      val make : unit -> bool
     val deliver' : string option -> bool  
     val deliver : unit -> bool  
23      val reset : unit -> unit      val reset : unit -> unit
24      val symval : string -> { get: unit -> int option, set: int option -> unit }      val symval : string -> { get: unit -> int option, set: int option -> unit }
25  end = struct  end = struct
   
     structure EM = GenericVC.ErrorMsg  
     structure E = GenericVC.Environment  
     structure SE = GenericVC.CMStaticEnv  
     structure BE = GenericVC.BareEnvironment  
     structure PS = GenericVC.PersStamps  
     structure CoerceEnv = GenericVC.CoerceEnv  
26      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
27                                        val os = os)                                        val os = os)
28      structure P = OS.Path      structure P = OS.Path
# Line 33  Line 33 
33      val osname = FilenamePolicy.kind2name os      val osname = FilenamePolicy.kind2name os
34      val archos = concat [arch, "-", osname]      val archos = concat [arch, "-", osname]
35    
36      fun init_servers (GroupGraph.GROUP { grouppath, ... }) =      fun init_servers (GG.GROUP { grouppath, ... }) =
37          Servers.cmb { archos = archos,          Servers.cmb { archos = archos,
38                        root = SrcPath.descr grouppath }                        root = SrcPath.descr grouppath }
39          | init_servers GG.ERRORGROUP = ()
40    
41        structure StabModmap = StabModmapFn ()
42    
43      structure Compile = CompileFn (structure MachDepVC = MachDepVC      structure Compile = CompileFn (structure MachDepVC = MachDepVC
44                                       structure StabModmap = StabModmap
45                                     val compile_there =                                     val compile_there =
46                                         Servers.compile o SrcPath.descr)                                         Servers.compile o SrcPath.descr)
47    
# Line 46  Line 50 
50      (* instantiate Stabilize... *)      (* instantiate Stabilize... *)
51      structure Stabilize =      structure Stabilize =
52          StabilizeFn (structure MachDepVC = MachDepVC          StabilizeFn (structure MachDepVC = MachDepVC
53                         structure StabModmap = StabModmap
54                       fun recomp gp g = let                       fun recomp gp g = let
55                           val { store, get } = BFC.new ()                           val { store, get } = BFC.new ()
56                           val _ = init_servers g                           val _ = init_servers g
# Line 59  Line 64 
64                       end                       end
65                       val getII = Compile.getII)                       val getII = Compile.getII)
66    
67        structure VerifyStable = VerStabFn (structure Stabilize = Stabilize)
68    
69      (* ... and Parse *)      (* ... and Parse *)
70      structure Parse = ParseFn (structure Stabilize = Stabilize      structure Parse = ParseFn (structure Stabilize = Stabilize
71                                   structure StabModmap = StabModmap
72                                 val evictStale = Compile.evictStale                                 val evictStale = Compile.evictStale
73                                 fun pending () = SymbolMap.empty)                                 fun pending () = SymbolMap.empty)
74    
# Line 82  Line 90 
90          MkBootList.group listName g          MkBootList.group listName g
91      end      end
92    
93      fun mk_compile deliver root dbopt = let      local
94            fun internal_reset () =
95                (Compile.reset ();
96                 Parse.reset ();
97                 StabModmap.reset ())
98        in
99            fun reset () =
100                (Say.vsay ["[CMB reset]\n"];
101                 internal_reset ())
102            val checkDirbase = let
103                val prev = ref NONE
104                fun ck db =
105                    (case !prev of
106                         NONE => prev := SOME db
107                       | SOME db' =>
108                         if db = db' then ()
109                         else (Say.vsay ["[new dirbase is `", db,
110                                         "'; CMB reset]\n"];
111                               internal_reset ();
112                               prev := SOME db))
113            in
114                ck
115            end
116        end
117    
118        fun mk_compile { deliver, root, dirbase = dbopt, paranoid } = let
119    
120            val _ = StabModmap.reset ()
121    
122          val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)          val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
123            val _ = checkDirbase dirbase
124          val pcmodespec = BtNames.pcmodespec          val pcmodespec = BtNames.pcmodespec
125          val initgspec = BtNames.initgspec          val initgspec = BtNames.initgspec
126          val maingspec = BtNames.maingspec          val maingspec = BtNames.maingspec
# Line 114  Line 150 
150              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
151                  { arch = arch, os = os }                  { arch = arch, os = os }
152    
153          fun mkParam corenv =          val param =
154              { fnpolicy = fnpolicy,              { fnpolicy = fnpolicy,
155                pcmode = pcmode,                pcmode = pcmode,
156                symval = SSV.symval,                symval = SSV.symval,
157                keep_going = keep_going,                keep_going = keep_going }
               corenv = corenv }  
158    
159          val emptydyn = E.dynamicPart E.emptyEnv          val emptydyn = E.dynamicPart E.emptyEnv
160    
161          (* first, build an initial GeneralParam.info, so we can          (* first, build an initial GeneralParam.info, so we can
162           * deal with the pervasive env and friends... *)           * deal with the pervasive env and friends... *)
163    
         val param_nocore = mkParam BE.emptyEnv  
   
164          val groupreg = GroupReg.new ()          val groupreg = GroupReg.new ()
165          val errcons = EM.defaultConsumer ()          val errcons = EM.defaultConsumer ()
166          val ginfo_nocore = { param = param_nocore, groupreg = groupreg,          val ginfo = { param = param, groupreg = groupreg, errcons = errcons }
                              errcons = errcons }  
167    
168          fun mk_main_compile arg = let          fun mk_main_compile arg = let
169    
170              val { core = core_n, pervasive = perv_n, others, src } = arg              val { pervasive = perv_n, others, src } = arg
171    
172                fun recompInitGroup () = let
173              val ovldR = GenericVC.Control.overloadKW              val ovldR = GenericVC.Control.overloadKW
174              val savedOvld = !ovldR              val savedOvld = !ovldR
175              val _ = ovldR := true              val _ = ovldR := true
176              val sbnode = Compile.newSbnodeTraversal ()              val sbnode = Compile.newSbnodeTraversal ()
177    
             (* here we build a new gp -- the one that uses the freshly  
              * brewed pervasive env, core env, and primitives *)  
             val core = valOf (sbnode ginfo_nocore core_n)  
             val corenv =  
                 BE.mkenv { static = CoerceEnv.es2bs (#env (#statenv core ())),  
                            symbolic = #symenv core (),  
                            dynamic = BE.dynamicPart BE.emptyEnv }  
   
             (* The following is a bit of a hack (but corenv is a hack anyway):  
              * As soon as we have core available, we have to patch the  
              * ginfo to include the correct corenv (because virtually  
              * everybody else needs access to corenv). *)  
             val param = mkParam corenv  
             val ginfo =  
                 { param = param, groupreg = groupreg, errcons = errcons }  
   
178              val perv_fsbnode = (NONE, perv_n)              val perv_fsbnode = (NONE, perv_n)
179    
180              fun rt n = valOf (sbnode ginfo n)              fun rt n = valOf (sbnode ginfo n)
181              val pervasive = rt perv_n              val pervasive = rt perv_n
182    
183              fun rt2ie (n, ii: IInfo.info) = let              fun rt2ie (n, ii: IInfo.info) = let
184                  val bs = CoerceEnv.es2bs (#env (#statenv ii ()))                      val s = #statenv ii ()
185                  val (dae, mkDomain) = Statenv2DAEnv.cvt bs                      val (dae, mkDomain) = Statenv2DAEnv.cvt s
186              in              in
187                        (* Link path info = NONE, will be reset at import
188                         * time (in members.sml). *)
189                  { ie = ((NONE, n), dae), mkDomain = mkDomain }                  { ie = ((NONE, n), dae), mkDomain = mkDomain }
190              end              end
191    
# Line 180  Line 199 
199              val special_exports = let              val special_exports = let
200                  fun mkie (n, rtn) = #ie (rt2ie (n, rtn))                  fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
201              in              in
202                  foldl SymbolMap.insert' SymbolMap.empty                      SymbolMap.insert (SymbolMap.empty,
203                        [(PervCoreAccess.pervStrSym, mkie (perv_n, pervasive)),                                        PervAccess.pervStrSym,
204                         (PervCoreAccess.coreStrSym, mkie (core_n, core))]                                        mkie (perv_n, pervasive))
205              end              end
206                in
207              val init_group = GroupGraph.GROUP                  GG.GROUP { exports = foldl add_exports special_exports others,
208                  { exports = foldl add_exports special_exports others,                             kind = GroupGraph.LIB { wrapped = StringSet.empty,
209                    kind = GroupGraph.LIB (StringSet.empty, []),                                                     subgroups = [] },
210                    required = StringSet.singleton "primitive",                    required = StringSet.singleton "primitive",
211                    grouppath = initgspec,                    grouppath = initgspec,
212                    sublibs = [] }                    sublibs = [] }
213                    before (ovldR := savedOvld)
214                end
215    
216              val _ = ovldR := savedOvld              (* just go and load the stable init group or signal failure *)
217                fun loadInitGroup () = let
218              (* At this point we check if there is a usable stable version                  val lsarg =
219               * of the init group.  If so, we continue to use that. *)                      { getGroup = fn _ => raise Fail "CMB: initial getGroup",
             val (stab, init_group, deliver) = let  
                 fun nostabinit () =  
                     if deliver then  
                         let val stabarg = { group = init_group,  
220                                              anyerrors = ref false }                                              anyerrors = ref false }
221                          in                          in
222                              case Stabilize.stabilize ginfo stabarg of                  case Stabilize.loadStable ginfo lsarg initgspec of
223                                  SOME g => (SOME true, g, true)                      NONE => NONE
224                                (* if we cannot stabilize the init group, then                    | SOME (g as GG.GROUP { exports, ... }) => SOME g
225                                 * as a first remedy we turn delivery off *)                    | SOME GG.ERRORGROUP => NONE
                               | NONE => (NONE, init_group, false)  
                         end  
                     else (NONE, init_group, false)  
             in  
                 if VerifyStable.verify ginfo init_group then let  
                     fun load () =  
                         Stabilize.loadStable ginfo  
                           { getGroup = fn _ =>  
                                raise Fail "CMB: initial getGroup",  
                             anyerrors = ref false }  
                           initgspec  
                 in  
                     case load () of  
                         NONE => nostabinit ()  
                       | SOME g =>  
                             (if deliver then SOME true else NONE, g, deliver)  
226                  end                  end
227                  else nostabinit ()  
228                (* Don't try to load the stable init group. Instead, recompile
229                 * directly. *)
230                fun dontLoadInitGroup () = let
231                    val g0 = recompInitGroup ()
232                    val stabarg = { group = g0, anyerrors = ref false }
233                in
234                    if deliver then
235                        case Stabilize.stabilize ginfo stabarg of
236                            SOME g => g
237                          | NONE => raise Fail "CMB: cannot stabilize init group"
238                    else g0
239                end
240    
241                (* Try loading the init group from the stable file if possible;
242                 * recompile if loading fails *)
243                fun tryLoadInitGroup () =
244                    case loadInitGroup () of
245                        SOME g => g
246                      | NONE => dontLoadInitGroup ()
247    
248                (* Ok, now, based on "paranoid" and stable verification,
249                 * call the appropriate function(s) to get the init group. *)
250                val init_group =
251                    if paranoid then let
252                        val export_nodes = perv_n :: others
253                        val ver_arg = (initgspec, export_nodes, [],
254                                       SrcPathSet.empty)
255                        val em = StableMap.empty
256                    in
257                        if VerifyStable.verify' ginfo em ver_arg then
258                            tryLoadInitGroup ()
259                        else dontLoadInitGroup ()
260              end              end
261                    else tryLoadInitGroup ()
262    
263    
264                val stab = if deliver then SOME true else NONE
265    
266              val gr = GroupReg.new ()              val gr = GroupReg.new ()
267              val _ = GroupReg.register gr (initgspec, src)              val _ = GroupReg.register gr (initgspec, src)
# Line 236  Line 273 
273                    stabflag = stab,                    stabflag = stab,
274                    group = maingspec,                    group = maingspec,
275                    init_group = init_group,                    init_group = init_group,
276                    paranoid = true }                    paranoid = paranoid }
277          in          in
278              Servers.dirbase dirbase;              Servers.dirbase dirbase;
             Parse.reset ();  
279              case Parse.parse parse_arg of              case Parse.parse parse_arg of
280                  NONE => NONE                  NONE => NONE
281                | SOME (g, gp) => let                | SOME (g, gp) => let
# Line 260  Line 296 
296                                                 stablelibs                                                 stablelibs
297                              fun writeBootList s = let                              fun writeBootList s = let
298                                  fun wr str = TextIO.output (s, str ^ "\n")                                  fun wr str = TextIO.output (s, str ^ "\n")
299                                    val numitems = length bootitems
300                                    fun biggerlen (s, n) = Int.max (size s, n)
301                                    val maxlen = foldl biggerlen 0 bootitems
302                              in                              in
303                                    wr (concat ["%", Int.toString numitems,
304                                                " ", Int.toString maxlen]);
305                                  app wr bootitems                                  app wr bootitems
306                              end                              end
307                              fun writePid s i = let                              fun writePid s i = let
# Line 314  Line 355 
355          end handle Option => (Compile.reset (); NONE)          end handle Option => (Compile.reset (); NONE)
356                     (* to catch valOf failures in "rt" *)                     (* to catch valOf failures in "rt" *)
357      in      in
358          case BuildInitDG.build ginfo_nocore initgspec of          case BuildInitDG.build ginfo initgspec of
359              SOME x => mk_main_compile x              SOME x => mk_main_compile x
360            | NONE => NONE            | NONE => NONE
361      end      end
362    
363      fun compile deliver dbopt =      fun compile dbopt =
364          case mk_compile deliver NONE dbopt of          case mk_compile { deliver = true, root = NONE,
365                              dirbase = dbopt, paranoid = true } of
366              NONE => false              NONE => false
367            | SOME (_, thunk) => thunk ()            | SOME (_, thunk) => thunk ()
368    
369      local      local
370          fun slave (dirbase, root) =          fun slave (dirbase, root) =
371              case mk_compile false (SOME root) (SOME dirbase) of              case mk_compile { deliver = false, root = SOME root,
372                                  dirbase = SOME dirbase, paranoid = false } of
373                  NONE => NONE                  NONE => NONE
374                | SOME ((g, gp, pcmode), _) => let                | SOME ((g, gp, pcmode), _) => let
375                      val trav = Compile.newSbnodeTraversal () gp                      val trav = Compile.newSbnodeTraversal () gp
# Line 338  Line 381 
381          val _ = CMBSlaveHook.init archos slave          val _ = CMBSlaveHook.init archos slave
382      end      end
383    
384      fun reset () =      val make' = compile
         (Compile.reset ();  
          Parse.reset ())  
   
     val make' = compile false  
385      fun make () = make' NONE      fun make () = make' NONE
     fun deliver' arg =  
         SafeIO.perform { openIt = fn () => (),  
                          closeIt = reset,  
                          work = fn () => compile true arg,  
                          cleanup = fn _ => () }  
     fun deliver () = deliver' NONE  
386      val symval = SSV.symval      val symval = SSV.symval
387  end  end
388    end (* local *)

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

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