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 460, Wed Nov 3 02:23:44 1999 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                              val os : SMLofNJ.SysInfo.os_kind) :> sig      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
20                 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 32  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, root = grouppath }          Servers.cmb { archos = archos,
38                          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                                     val compile_there = Servers.compile)                                     structure StabModmap = StabModmap
45                                       val compile_there =
46                                           Servers.compile o SrcPath.descr)
47    
48      structure BFC = BfcFn (structure MachDepVC = MachDepVC)      structure BFC = BfcFn (structure MachDepVC = MachDepVC)
49    
50      (* instantiate Stabilize... *)      (* instantiate Stabilize... *)
51      structure Stabilize =      structure Stabilize =
52          StabilizeFn (fun destroy_state _ i = Compile.evict i          StabilizeFn (structure MachDepVC = MachDepVC
53                       structure MachDepVC = MachDepVC                       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 57  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
73                                 fun pending () = SymbolMap.empty)                                 fun pending () = SymbolMap.empty)
74    
75      (* copying an input file to an output file safely... *)      fun mkBootList g = let
76      fun copyFile (oi, ci, oo, co, inp, outp, eof) (inf, outf) = let          fun listName p =
77          fun workIn is = let              case P.fromString p of
78              fun workOut os = let                  { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
79                  val N = 4096                      fun win32name () =
80                  fun loop () =                          concat (arc1 ::
81                      if eof is then () else (outp (os, inp (is, N)); loop ())                                  foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
             in  
                 loop ()  
             end  
82          in          in
83              SafeIO.perform { openIt = fn () => oo outf,                      case os of
84                               closeIt = co,                          SMLofNJ.SysInfo.WIN32 => win32name ()
85                               work = workOut,                        | _ => P.toString { isAbs = false, vol = "",
86                               cleanup = fn _ =>                                            arcs = arc1 :: arcn }
                                  (F.remove outf handle _ => ()) }  
87          end          end
88                  | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
89      in      in
90          SafeIO.perform { openIt = fn () => oi inf,          MkBootList.group listName g
                          closeIt = ci,  
                          work = workIn,  
                          cleanup = fn _ => () }  
91      end      end
92    
93      val copyTextFile =      local
94          copyFile (TextIO.openIn, TextIO.closeIn,          fun internal_reset () =
95                    AutoDir.openTextOut, TextIO.closeOut,              (Compile.reset ();
96                    TextIO.inputN, TextIO.output, TextIO.endOfStream)               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      val copyBinFile =      fun mk_compile { deliver, root, dirbase = dbopt, paranoid } = let
         copyFile (BinIO.openIn, BinIO.closeIn,  
                   AutoDir.openBinOut, BinIO.closeOut,  
                   BinIO.inputN, BinIO.output, BinIO.endOfStream)  
119    
120      fun mk_compile deliver root dbopt = let          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
127    
128          val bindir = concat [dirbase, ".bin.", archos]          val bindir = concat [dirbase, BtNames.bin_infix, archos]
129          val bootdir = concat [dirbase, ".boot.", archos]          val bootdir = concat [dirbase, BtNames.boot_infix, archos]
   
         fun listName (p, copy) =  
             case P.fromString p of  
                 { vol = "", isAbs = false, arcs = arc0 :: arc1 :: arcn } => let  
                     fun win32name () =  
                         concat (arc1 ::  
                                 foldr (fn (a, r) => "\\" :: a :: r) [] arcn)  
                     fun doCopy () = let  
                         val bootpath =  
                             P.toString { isAbs = false, vol = "",  
                                          arcs = bootdir :: arc1 :: arcn }  
                     in  
                         copyBinFile (p, bootpath)  
                     end  
                 in  
                     if copy andalso arc0 = bindir then doCopy () else ();  
                     case os of  
                         SMLofNJ.SysInfo.WIN32 => win32name ()  
                       | _ => P.toString { isAbs = false, vol = "",  
                                           arcs = arc1 :: arcn }  
                 end  
               | _ => raise Fail "BootstrapCompile:listName: bad name"  
130    
131          val keep_going = #get StdConfig.keep_going ()          val keep_going = #get StdConfig.keep_going ()
132    
133          val ctxt = SrcPath.cwdContext ()          val ctxt = SrcPath.cwdContext ()
134    
135          val pidfile = P.joinDirFile { dir = bootdir, file = "RTPID" }          val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
136          val listfile = P.joinDirFile { dir = bootdir, file = "BOOTLIST" }          val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
137    
138          val pcmode = PathConfig.new ()          val pcmode = PathConfig.new ()
139          val _ = PathConfig.processSpecFile (pcmode, pcmodespec)          val _ = PathConfig.processSpecFile (pcmode, pcmodespec)
# Line 145  Line 146 
146                  NONE => stdpath maingspec                  NONE => stdpath maingspec
147                | SOME r => SrcPath.fromDescr pcmode r                | SOME r => SrcPath.fromDescr pcmode r
148    
         val cmifile = valOf (SrcPath.reAnchoredName (initgspec, bootdir))  
             handle Option => raise Fail "BootstrapCompile: cmifile"  
   
149          val fnpolicy =          val fnpolicy =
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 { primconf, pervasive, pervcorepids }          val param =
154                      { corenv } =              { fnpolicy = fnpolicy,
             { primconf = primconf,  
               fnpolicy = fnpolicy,  
155                pcmode = pcmode,                pcmode = pcmode,
156                symval = SSV.symval,                symval = SSV.symval,
157                keep_going = keep_going,                keep_going = keep_going }
               pervasive = pervasive,  
               corenv = corenv,  
               pervcorepids = pervcorepids }  
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 primconf = Primitive.primEnvConf  
         val mkInitParam = mkParam { primconf = primconf,  
                                     pervasive = E.emptyEnv,  
                                     pervcorepids = PidSet.empty }  
   
         val param_nocore = mkInitParam { corenv = BE.staticPart 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 { rts, core, pervasive, primitives, binpaths } = 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    
178              (* here we build a new gp -- the one that uses the freshly                  val perv_fsbnode = (NONE, perv_n)
              * brewed pervasive env, core env, and primitives *)  
             val core = valOf (sbnode ginfo_nocore core)  
             val corenv =  CoerceEnv.es2bs (#statenv core ())  
             val core_sym = #symenv core ()  
   
             (* 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_justcore = mkInitParam { corenv = corenv }  
             val ginfo_justcore = { param = param_justcore, groupreg = groupreg,  
                                    errcons = errcons }  
   
             fun rt n = valOf (sbnode ginfo_justcore n)  
             val rts = rt rts  
             val pervasive = rt pervasive  
   
             fun sn2pspec (name, n) = let  
                 val { statenv, symenv, statpid, sympid } = rt n  
                 val env =  
                     E.mkenv { static = statenv (),  
                               symbolic = symenv (),  
                               dynamic = emptydyn }  
                 val pidInfo = { statpid = statpid, sympid = sympid }  
             in  
                 { name = name, env = env, pidInfo = pidInfo }  
             end  
   
             val pspecs = map sn2pspec primitives  
   
             val _ = ovldR := savedOvld  
   
             (* The following is a hack but must be done for both the symbolic  
              * and later the dynamic part of the core environment:  
              * we must include these parts in the pervasive env. *)  
             val perv_sym = E.layerSymbolic (#symenv pervasive (),  
                                             core_sym)  
179    
180              val param =                  fun rt n = valOf (sbnode ginfo n)
181                  mkParam { primconf = Primitive.configuration pspecs,                  val pervasive = rt perv_n
182                            pervasive = E.mkenv { static = #statenv pervasive (),  
183                                                  symbolic = perv_sym,                  fun rt2ie (n, ii: IInfo.info) = let
184                                                  dynamic = emptydyn },                      val s = #statenv ii ()
185                            pervcorepids =                      val (dae, mkDomain) = Statenv2DAEnv.cvt s
186                              PidSet.addList (PidSet.empty,                  in
187                                              [#statpid pervasive,                      (* Link path info = NONE, will be reset at import
188                                               #sympid pervasive,                       * time (in members.sml). *)
189                                               #statpid core]) }                      { ie = ((NONE, n), dae), mkDomain = mkDomain }
190                          { corenv = corenv }                  end
191              val stab =  
192                  if deliver then SOME true else NONE                  fun add_exports (n, exports) = let
193                        val { ie, mkDomain } = rt2ie (n, rt n)
194                        fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
195                    in
196                        SymbolSet.foldl ins_ie exports (mkDomain ())
197                    end
198    
199                    val special_exports = let
200                        fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
201                    in
202                        SymbolMap.insert (SymbolMap.empty,
203                                          PervAccess.pervStrSym,
204                                          mkie (perv_n, pervasive))
205                    end
206                in
207                    GG.GROUP { exports = foldl add_exports special_exports others,
208                               kind = GroupGraph.LIB { wrapped = StringSet.empty,
209                                                       subgroups = [] },
210                               required = StringSet.singleton "primitive",
211                               grouppath = initgspec,
212                               sublibs = [] }
213                    before (ovldR := savedOvld)
214                end
215    
216                (* just go and load the stable init group or signal failure *)
217                fun loadInitGroup () = let
218                    val lsarg =
219                        { getGroup = fn _ => raise Fail "CMB: initial getGroup",
220                          anyerrors = ref false }
221                in
222                    case Stabilize.loadStable ginfo lsarg initgspec of
223                        NONE => NONE
224                      | SOME (g as GG.GROUP { exports, ... }) => SOME g
225                      | SOME GG.ERRORGROUP => NONE
226                end
227    
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
261                    else tryLoadInitGroup ()
262    
263    
264                val stab = if deliver then SOME true else NONE
265    
266                val gr = GroupReg.new ()
267                val _ = GroupReg.register gr (initgspec, src)
268    
269                val parse_arg =
270                    { load_plugin = load_plugin,
271                      gr = gr,
272                      param = param,
273                      stabflag = stab,
274                      group = maingspec,
275                      init_group = init_group,
276                      paranoid = paranoid }
277          in          in
278              Servers.dirbase dirbase;              Servers.dirbase dirbase;
279              case Parse.parse NONE param stab maingspec of              case Parse.parse parse_arg of
280                  NONE => NONE                  NONE => NONE
281                | SOME (g, gp) => let                | SOME (g, gp) => let
282                      fun thunk () = let                      fun thunk () = let
# Line 255  Line 288 
288                              Servers.withServers (fn () => recomp gp)                              Servers.withServers (fn () => recomp gp)
289                      in                      in
290                          if isSome res then let                          if isSome res then let
291                              val rtspid = PS.toHex (#statpid rts)                              val { l = bootitems, ss } = mkBootList g
292                              fun writeList s = let                              val stablelibs = Reachable.stableLibsOf g
293                                  fun add ((p, flag), l) = let                              fun inSet bi = StableSet.member (ss, bi)
294                                      val n = listName (p, true)                              val frontiers =
295                                  in                                  SrcPathMap.map (Reachable.frontier inSet)
296                                      if flag then n :: l else l                                                 stablelibs
297                                  end                              fun writeBootList s = let
298                                  fun transcribe (p, NONE) = listName (p, true)                                  fun wr str = TextIO.output (s, str ^ "\n")
299                                    | transcribe (p, SOME (off, desc)) =                                  val numitems = length bootitems
300                                      concat [listName (p, false),                                  fun biggerlen (s, n) = Int.max (size s, n)
301                                              "@", Int.toString off, ":", desc]                                  val maxlen = foldl biggerlen 0 bootitems
302                                  val bootstrings =                              in
303                                      foldr add                                  wr (concat ["%", Int.toString numitems,
304                                            (map transcribe (MkBootList.group g))                                              " ", Int.toString maxlen]);
305                                            binpaths                                  app wr bootitems
306                                  fun show str =                              end
307                                      (TextIO.output (s, str);                              fun writePid s i = let
308                                    val sn = BinInfo.stablename i
309                                    val os = BinInfo.offset i
310                                    val descr = BinInfo.describe i
311                                    val bfc = BFC.getStable
312                                        { stable = sn, offset = os, descr = descr }
313                                in
314                                    case BF.exportPidOf bfc of
315                                        NONE => ()
316                                      | SOME pid =>
317                                            (TextIO.output (s, " ");
318                                             TextIO.output (s, PS.toHex pid))
319                                end
320                                fun writePidLine s (p, set) =
321                                    if StableSet.isEmpty set then ()
322                                    else (TextIO.output (s, SrcPath.descr p);
323                                          StableSet.app (writePid s) set;
324                                       TextIO.output (s, "\n"))                                       TextIO.output (s, "\n"))
325                              in                              fun writePidMap s =
326                                  app show bootstrings                                  SrcPathMap.appi (writePidLine s) frontiers
                             end  
327                          in                          in
328                              if deliver then                              if deliver then
329                                  (SafeIO.perform                                  (SafeIO.perform
330                                   { openIt = fn () =>                                   { openIt = fn () =>
331                                         AutoDir.openTextOut pidfile,                                         AutoDir.openTextOut listfile,
332                                     closeIt = TextIO.closeOut,                                     closeIt = TextIO.closeOut,
333                                     work = fn s =>                                     work = writeBootList,
                                        TextIO.output (s, rtspid ^ "\n"),  
334                                     cleanup = fn _ =>                                     cleanup = fn _ =>
335                                         OS.FileSys.remove pidfile                                         OS.FileSys.remove listfile
336                                         handle _ => () };                                         handle _ => () };
337                                   SafeIO.perform                                   SafeIO.perform
338                                   { openIt = fn () =>                                   { openIt = fn () =>
339                                         AutoDir.openTextOut listfile,                                         AutoDir.openTextOut pidmapfile,
340                                     closeIt = TextIO.closeOut,                                     closeIt = TextIO.closeOut,
341                                     work = writeList,                                     work = writePidMap,
342                                     cleanup = fn _ =>                                     cleanup = fn _ =>
343                                         OS.FileSys.remove listfile                                         OS.FileSys.remove pidmapfile
344                                         handle _ => () };                                         handle _ => () };
345                                   copyTextFile (SrcPath.osstring initgspec,                                   Say.say
346                                                 cmifile);                                        ["New boot directory has been built.\n"])
                                  Say.say ["Runtime System PID is: ",  
                                           rtspid, "\n"])  
347                              else ();                              else ();
348                              true                              true
349                          end                          end
# Line 310  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 334  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.460  
changed lines
  Added in v.592

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