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 335, Thu Jun 17 08:21:08 1999 UTC revision 854, Wed Jun 27 19:11:38 2001 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
                             val os: SMLofNJ.SysInfo.os_kind) = struct  
   
10      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
11      structure E = GenericVC.Environment      structure E = GenericVC.Environment
12      structure SE = GenericVC.CMStaticEnv      structure SE = GenericVC.StaticEnv
     structure BE = GenericVC.BareEnvironment  
13      structure PS = GenericVC.PersStamps      structure PS = GenericVC.PersStamps
14      structure CoerceEnv = GenericVC.CoerceEnv      structure GG = GroupGraph
15        structure DG = DependencyGraph
16      (* Since the bootstrap compiler never executes any of the code  in
17       * it produces, we don't need any dynamic values.  Therefore,  functor BootstrapCompileFn
18       * we create RecompPersstate (but not FullPersstate!) and              (structure MachDepVC : MACHDEP_VC
19       * instantiate Recomp as well as RecompTraversal.               val useStream : TextIO.instream -> unit
20       * Since RecompPersstate is not part of any surrounding FullPersstate,               val os : SMLofNJ.SysInfo.os_kind
21       * function "discard_value" simply does nothing. *)               val load_plugin : SrcPath.dir -> string -> bool) =
22      structure RecompPersstate =  struct
23          RecompPersstateFn (structure MachDepVC = MachDepVC      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
24                             val discard_code = true                                        val os = os)
25                             fun discard_value (i: SmlInfo.info) = ())      structure P = OS.Path
26      structure Recomp = RecompFn (structure PS = RecompPersstate)      structure F = OS.FileSys
27      structure RT = CompileGenericFn (structure CT = Recomp)      structure BF = MachDepVC.Binfile
28    
29        val arch = MachDepVC.architecture
30        val osname = FilenamePolicy.kind2name os
31    
32        val archos = concat [arch, "-", osname]
33    
34        structure StabModmap = StabModmapFn ()
35    
36        structure Compile = CompileFn (structure MachDepVC = MachDepVC
37                                       structure StabModmap = StabModmap
38                                       val useStream = useStream
39                                       val compile_there =
40                                           Servers.compile o SrcPath.encode)
41    
42      fun recomp gp g = isSome (RT.group gp g)      structure BFC = BfcFn (structure MachDepVC = MachDepVC)
43    
44      (* instantiate Stabilize... *)      (* instantiate Stabilize... *)
45      structure Stabilize =      structure Stabilize =
46          StabilizeFn (fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))          StabilizeFn (structure MachDepVC = MachDepVC
47                       val recomp = recomp)                       structure StabModmap = StabModmap
48      (* ... and Parse *)                       fun recomp gp g = let
49      structure Parse = ParseFn (structure Stabilize = Stabilize)                           val { store, get } = BFC.new ()
50                             fun dummy _ _ = ()
51      fun compile { binroot, pcmodespec, initgspec, maingspec } = let                           val { group, ... } =
52                                 Compile.newTraversal (dummy, store, g)
53          val keep_going = EnvConfig.getSet StdConfig.keep_going NONE                       in
54                             case group gp of
55          val ctxt = AbsPath.cwdContext ()                               NONE => NONE
56                               | SOME _ => SOME get
57                         end
58                         val getII = Compile.getII)
59    
60          val initgspec = AbsPath.native { context = ctxt, spec = initgspec }      structure VerifyStable = VerStabFn (structure Stabilize = Stabilize)
         val maingspec = AbsPath.native { context = ctxt, spec = maingspec }  
         val pcmodespec = AbsPath.native { context = ctxt, spec = pcmodespec }  
         val binroot = AbsPath.native { context = ctxt, spec = binroot }  
61    
62          fun build_pcmode () = let      (* ... and Parse *)
63              val s = AbsPath.openTextIn pcmodespec      structure Parse = ParseFn (structure Stabilize = Stabilize
64              fun loop l = let                                 structure StabModmap = StabModmap
65                  val line = TextIO.inputLine s                                 val evictStale = Compile.evictStale
66                                   fun pending () = SymbolMap.empty)
67    
68        fun mkBootList g = let
69            fun listName p =
70                case P.fromString p of
71                    { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
72                        fun win32name () =
73                            concat (arc1 ::
74                                    foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
75                    in
76                        case os of
77                            SMLofNJ.SysInfo.WIN32 => win32name ()
78                          | _ => P.toString { isAbs = false, vol = "",
79                                              arcs = arc1 :: arcn }
80                    end
81                  | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
82              in              in
83                  if line = "" then PathConfig.hardwire l          MkBootList.group listName g
                 else case String.tokens Char.isSpace line of  
                     [a, s] => loop ((a, s) :: l)  
                   | _ => (Say.say [AbsPath.name pcmodespec,  
                                    ": malformed line (ignored)\n"];  
                           loop l)  
84              end              end
85    
86        fun internal_reset () =
87            (Compile.reset ();
88             Parse.reset ();
89             StabModmap.reset ())
90    
91        fun reset () =
92            (Say.vsay ["[CMB reset]\n"];
93             Servers.withServers (fn () => Servers.cmb_reset { archos = archos });
94             internal_reset ())
95    
96        val checkDirbase = let
97            val prev = ref NONE
98            fun ck db =
99                (case !prev of
100                     NONE => prev := SOME db
101                   | SOME db' =>
102                     if db = db' then ()
103                     else (Say.vsay ["[new dirbase is `", db,
104                                     "'; CMB reset]\n"];
105                           internal_reset ();
106                           prev := SOME db))
107          in          in
108              loop [] before TextIO.closeIn s          ck
109          end          end
110    
111          val pcmode = build_pcmode ()      fun mk_compile { master, root, dirbase = dbopt } = let
112    
113            val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
114            val _ = checkDirbase dirbase
115            val penvspec = BtNames.penvspec
116            val initgspec = BtNames.initgspec
117            val maingspec = BtNames.maingspec
118    
119            val bindir = concat [dirbase, BtNames.bin_infix, archos]
120            val bootdir = concat [dirbase, BtNames.boot_infix, archos]
121    
122            val keep_going = #get StdConfig.keep_going ()
123    
124            val ctxt = SrcPath.cwd ()
125    
126            val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
127            val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
128    
129            val penv = SrcPath.newEnv ()
130            val _ = SafeIO.perform { openIt = fn () => TextIO.openIn penvspec,
131                                     closeIt = TextIO.closeIn,
132                                     work = SrcPath.processSpecFile
133                                                { env = penv, specfile = penvspec,
134                                                  say = Say.say },
135                                     cleanup = fn _ => () }
136            val _ = SrcPath.sync ()
137    
138            fun stdpath s =
139                SrcPath.file (SrcPath.standard
140                                  { err = fn s => raise Fail s, env = penv }
141                                  { context = ctxt, spec = s })
142    
143            val initgspec = stdpath initgspec
144            val maingspec =
145                case root of
146                    NONE => stdpath maingspec
147                  | SOME r => SrcPath.decode penv r
148    
149          val fnpolicy =          val fnpolicy =
150              FilenamePolicy.separate { root = binroot,              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
151                                        parentArc = "DOTDOT",                  { arch = arch, os = os }
152                                        absArc = "ABSOLUTE" }  
153                                      { arch = MachDepVC.architecture, os = os }          val param =
154                { fnpolicy = fnpolicy,
155                  penv = penv,
156                  symval = SSV.symval,
157                  keep_going = keep_going }
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... *)
         local  
             (* We could actually go and calculate the actual pid of primEnv.  
              * But in reality it's pretty pointless to do so... *)  
             val bogusPid = PS.fromBytes (Byte.stringToBytes "0123456789abcdef")  
             val pspec = { name = "primitive",  
                           env = E.mkenv { static = E.primEnv,  
                                           symbolic = E.symbolicPart E.emptyEnv,  
                                           dynamic = emptydyn },  
                           pidInfo = { statpid = bogusPid,  
                                       sympid = bogusPid,  
                                       ctxt = SE.empty } }  
         in  
             val primconf = Primitive.configuration [pspec]  
         end  
   
         val param_nocore = { primconf = primconf,  
                              fnpolicy = fnpolicy,  
                              pcmode = pcmode,  
                              keep_going = keep_going,  
                              pervasive = E.emptyEnv,  
                              corenv = BE.staticPart BE.emptyEnv,  
                              pervcorepids = PidSet.empty }  
163    
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,
167                               errcons = errcons }                        errcons = errcons,
168                          youngest = ref TStamp.ancient }
169    
170            fun mk_main_compile arg = let
171    
172          fun main_compile arg = let              val { pervasive = perv_n, others, src } = arg
             val { rts, core, pervasive, primitives, binpaths } = arg  
173    
174                fun recompInitGroup () = let
175              val ovldR = GenericVC.Control.overloadKW              val ovldR = GenericVC.Control.overloadKW
176              val savedOvld = !ovldR              val savedOvld = !ovldR
177              val _ = ovldR := true              val _ = ovldR := true
178                    val sbnode = Compile.newSbnodeTraversal ()
179    
180                    val perv_fsbnode = (NONE, perv_n)
181    
182                    fun rt n = valOf (sbnode n ginfo)
183                    val pervasive = rt perv_n
184    
185                    fun rt2ie (n, ii: IInfo.info) = let
186                        val s = #statenv ii ()
187                        val (dae, mkDomain) = Statenv2DAEnv.cvt s
188                        val domain = mkDomain ()
189                    in
190                        { ie = (fn () => (NONE, n), dae, domain), domain = domain }
191                    end
192    
193                    fun add_exports (n, exports) = let
194                        val { ie, domain } = rt2ie (n, rt n)
195                        fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
196                    in
197                        SymbolSet.foldl ins_ie exports domain
198                    end
199    
200                    val special_exports = let
201                        fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
202                    in
203                        SymbolMap.insert (SymbolMap.empty,
204                                          PervAccess.pervStrSym,
205                                          mkie (perv_n, pervasive))
206                    end
207                in
208                    GG.GROUP { exports = foldl add_exports special_exports others,
209                               kind = GG.LIB {
210                                 kind = GG.DEVELOPED { wrapped = StringSet.empty,
211                                                       subgroups = [] },
212                                    version = NONE },
213                               required = StringSet.singleton "primitive",
214                               grouppath = initgspec,
215                               (* hack: sources never used for this group *)
216                               sources = SrcPathMap.empty,
217                               sublibs = [] }
218                    before (ovldR := savedOvld)
219                end
220    
221                (* just go and load the stable init group or signal failure *)
222                fun loadInitGroup () = let
223                    val lsarg =
224                        { getGroup = fn _ => raise Fail "CMB: initial getGroup",
225                          anyerrors = ref false }
226                in
227                    case Stabilize.loadStable lsarg (ginfo, initgspec, NONE, []) of
228                        NONE => NONE
229                      | SOME (g as GG.GROUP { exports, ... }) => SOME g
230                      | SOME GG.ERRORGROUP => NONE
231                end
232    
233              (* here we build a new gp -- the one that uses the freshly              (* Don't try to load the stable init group. Instead, recompile
234               * brewed pervasive env, core env, and primitives *)               * directly. *)
235              val core = valOf (RT.snode ginfo_nocore core)              fun dontLoadInitGroup () = let
236              val corenv =  CoerceEnv.es2bs (#1 (#stat core))                  (* Function recompileInitGroup will not use servers (hence no
237              (* even though we have a pid for the core, we can't use it                   * call to Servers.withServers), but since compile traversals
238               * (otherwise we would invalidate earlier compilation results) *)                   * invoke the scheduler anyway, we must still clear pending
239              val pervcorepids = PidSet.empty                   * tasks when we hit an error or an interrupt. *)
240                    val g0 = SafeIO.perform { openIt = fn () => (),
241              (* The following is a bit of a hack (but corenv is a hack anyway):                                            closeIt = fn () => (),
242               * As soon as we have core available, we have to patch the                                            work = recompInitGroup,
243               * ginfo to include the correct corenv (because virtually                                            cleanup = Servers.reset }
244               * everybody else needs access to corenv). *)                  val stabarg = { group = g0, anyerrors = ref false,
245              val param_justcore = { primconf = primconf,                                  rebindings = [] }
                                    fnpolicy = fnpolicy,  
                                    pcmode = pcmode,  
                                    keep_going = keep_going,  
                                    pervasive = E.emptyEnv,  
                                    corenv = corenv,  
                                    pervcorepids = pervcorepids }  
             val ginfo_justcore = { param = param_justcore, groupreg = groupreg,  
                                    errcons = errcons }  
   
             fun rt n = valOf (RT.snode ginfo_justcore n)  
             val rts = rt rts  
             val pervasive = rt pervasive  
   
             fun sn2pspec (name, n) = let  
                 val { stat = (s, sp), sym = (sy, syp), ctxt } = rt n  
                 val env =  
                     E.mkenv { static = s, symbolic = sy, dynamic = emptydyn }  
                 val pidInfo = { statpid = sp, sympid = syp, ctxt = ctxt }  
             in  
                 { name = name, env = env, pidInfo = pidInfo }  
             end  
   
             val pspecs = map sn2pspec primitives  
   
             val _ = ovldR := savedOvld  
   
             val param = { primconf = Primitive.configuration pspecs,  
                           fnpolicy = fnpolicy,  
                           pcmode = pcmode,  
                           keep_going = keep_going,  
                           pervasive = E.mkenv { static = #1 (#stat pervasive),  
                                                 symbolic = #1 (#sym pervasive),  
                                                 dynamic = emptydyn },  
                           corenv = CoerceEnv.es2bs (#1 (#stat core)),  
                           pervcorepids =  
                             PidSet.addList (PidSet.empty,  
                                             [#2 (#stat pervasive),  
                                              #2 (#sym pervasive),  
                                              #2 (#stat core)]) }  
246          in          in
247              case Parse.parse param NONE maingspec of                  if master then
248                        case Stabilize.stabilize ginfo stabarg of
249                            SOME g => (Parse.reset (); g)
250                          | NONE => raise Fail "CMB: cannot stabilize init group"
251                    else g0
252                end
253    
254                (* Try loading the init group from the stable file if possible;
255                 * recompile if loading fails *)
256                fun tryLoadInitGroup () =
257                    case loadInitGroup () of
258                        SOME g => g
259                      | NONE => dontLoadInitGroup ()
260    
261                (* Ok, now, based on "paranoid" and stable verification,
262                 * call the appropriate function(s) to get the init group. *)
263                val init_group =
264                    if master then let
265                        val export_nodes = perv_n :: others
266                        val ver_arg = (initgspec, export_nodes, [],
267                                       SrcPathSet.empty, NONE)
268                        val em = StableMap.empty
269                    in
270                        if VerifyStable.verify' ginfo em ver_arg then
271                            tryLoadInitGroup ()
272                        else dontLoadInitGroup ()
273                    end
274                    else valOf (loadInitGroup ()) (* failure caught at the end *)
275    
276                val gr = GroupReg.new ()
277                val _ = GroupReg.register gr (initgspec, src)
278    
279                fun parse_arg (s, p) =
280                    { load_plugin = load_plugin,
281                      gr = gr,
282                      param = param,
283                      stabflag = s,
284                      group = maingspec,
285                      init_group = init_group,
286                      paranoid = p }
287    
288                val lonely_master = master andalso Servers.noServers ()
289    
290                val initial_parse_result =
291                    if master then
292                        if lonely_master then
293                            (* no slaves available; do everything alone
294                             * (Still wrap "withServers" around it to make sure
295                             * our queues get cleaned when an interrupt or error
296                             * occurs.) *)
297                            Servers.withServers
298                                (fn () => Parse.parse (parse_arg (SOME true, true)))
299                        else
300                            (* slaves available; we want master
301                             * and slave initialization to overlap, so
302                             * we do the master's parsing in its own
303                             * thread *)
304                            let fun worker () = let
305                                    val c =
306                                        Concur.fork
307                                            (fn () => Parse.parse
308                                                          (parse_arg (NONE, true)))
309                                in
310                                    Servers.cmb
311                                        { dirbase = dirbase,
312                                          archos = archos,
313                                          root = SrcPath.encode maingspec };
314                                    Concur.wait c
315                                end
316                            in
317                                Servers.withServers worker
318                            end
319                    else
320                        (* slave case *)
321                        Parse.parse (parse_arg (NONE, false))
322            in
323                case initial_parse_result of
324                  NONE => NONE                  NONE => NONE
325                | SOME (g, gp) =>                | SOME (g, gp) => let
326                      if recomp gp g then                      fun finish (g, gp) = let
327                          SOME { rtspid = PS.toHex (#2 (#stat rts)),                          val { l = bootitems, ss } = mkBootList g
328                                 bootfiles =                          val stablelibs = Reachable.stableLibsOf g
329                                   map (fn x => (x, NONE)) binpaths @                          fun inSet bi = StableSet.member (ss, bi)
330                                   MkBootList.group g }                          val frontiers =
331                      else NONE                              SrcPathMap.map (Reachable.frontier inSet)
332          end handle Option => (RT.clearFailures (); NONE)                                             stablelibs
333                     (* to catch valOf failures in "rt" *)                          fun writeBootList s = let
334                                fun wr str = TextIO.output (s, str ^ "\n")
335                                val numitems = length bootitems
336                                fun biggerlen (s, n) = Int.max (size s, n)
337                                val maxlen = foldl biggerlen 0 bootitems
338                            in
339                                wr (concat ["%", Int.toString numitems,
340                                            " ", Int.toString maxlen]);
341                                app wr bootitems
342                            end
343                            fun writePid s i = let
344                                val sn = BinInfo.stablename i
345                                val os = BinInfo.offset i
346                                val descr = BinInfo.describe i
347                                val bfc = BFC.getStable { stable = sn, offset = os,
348                                                          descr = descr }
349      in      in
350          case BuildInitDG.build ginfo_nocore initgspec of                              case BF.exportPidOf bfc of
351              SOME x => main_compile x                                  NONE => ()
352                                  | SOME pid =>
353                                    app (fn str => TextIO.output (s, str))
354                                        [" ", Int.toString os, ":", PS.toHex pid]
355                            end
356                            fun writePidLine s (p, set) =
357                                if StableSet.isEmpty set then ()
358                                else (TextIO.output (s, SrcPath.encode p);
359                                      StableSet.app (writePid s) set;
360                                      TextIO.output (s, "\n"))
361                            fun writePidMap s =
362                                SrcPathMap.appi (writePidLine s) frontiers
363                        in
364                            SafeIO.perform
365                                { openIt = fn () => AutoDir.openTextOut listfile,
366                                  closeIt = TextIO.closeOut,
367                                  work = writeBootList,
368                                  cleanup = fn _ => (OS.FileSys.remove listfile
369                                                     handle _ => ()) };
370                            SafeIO.perform
371                                { openIt = fn () => AutoDir.openTextOut pidmapfile,
372                                  closeIt = TextIO.closeOut,
373                                  work = writePidMap,
374                                  cleanup = fn _ => (OS.FileSys.remove pidmapfile
375                                                     handle _ => ()) };
376                            Say.say ["New boot directory has been built.\n"];
377                            true
378                        end
379    
380                        (* the following thunk represents phase 2 (stabilization)
381                         * of the master's execution path; it is never
382                         * executed in slave mode *)
383                        fun stabilize () =
384                            (* now we re-parse everything with stabilization
385                             * turnedon (and servers turned off *)
386                            case Parse.parse (parse_arg (SOME true, false)) of
387                                NONE => false
388                              | SOME (g, gp) => finish (g, gp)
389    
390                        (* Don't do another traversal if this is a lonely master *)
391                        fun just_stabilize () = finish (g, gp)
392    
393                        (* the following thunk is executed in "master" mode only;
394                         * slaves just throw it away *)
395                        fun compile_and_stabilize () = let
396    
397                            (* make compilation traversal and execute it *)
398                            val { allgroups, ... } =
399                                Compile.newTraversal (fn _ => fn _ => (),
400                                                      fn _ => (),
401                                                      g)
402                        in
403                            if Servers.withServers (fn () => allgroups gp) then
404                                (Compile.reset ();
405                                 stabilize ())
406                            else false
407                        end
408                    in
409                        SOME ((g, gp, penv),
410                              if lonely_master then just_stabilize
411                              else compile_and_stabilize)
412                    end
413            end handle Option => (Compile.reset (); NONE)
414                       (* to catch valOf failures in "rt" or slave's failure
415                        * to load init group *)
416        in
417            case BuildInitDG.build ginfo initgspec of
418                SOME x => mk_main_compile x
419            | NONE => NONE            | NONE => NONE
420      end      end
421    
422        fun compile dbopt =
423            (StabModmap.reset ();
424             case mk_compile { master = true, root = NONE, dirbase = dbopt } of
425                 NONE => false
426               | SOME (_, thunk) => thunk ())
427    
428        local
429            fun slave NONE = (internal_reset (); NONE)
430              | slave (SOME (dirbase, root)) =
431                (StabModmap.reset ();
432                 case mk_compile { master = false, root = SOME root,
433                                   dirbase = SOME dirbase } of
434                     NONE => NONE
435                   | SOME ((g, gp, penv), _) => let
436                         val trav = Compile.newSbnodeTraversal ()
437                         fun trav' sbn = isSome (trav sbn gp)
438                     in
439                         SOME (g, trav', penv)
440                     end)
441        in
442            val _ = CMBSlaveHook.init archos slave
443        end
444    
445        val make' = compile
446        fun make () = make' NONE
447        val symval = SSV.symval
448  end  end
449    end (* local *)

Legend:
Removed from v.335  
changed lines
  Added in v.854

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