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 357, Mon Jun 28 08:46:30 1999 UTC revision 734, Sun Nov 19 05:27:41 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
                             val os: SMLofNJ.SysInfo.os_kind) :> sig  
   
     val compile :  
         { dirbase: string,  
           pcmodespec: string,  
           initgspec: string,  
           maingspec: string,  
           stabilize: bool }  
         -> bool  
   
 end = 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    in
17    functor BootstrapCompileFn
18                (structure MachDepVC : MACHDEP_VC
19                 val useStream : TextIO.instream -> unit
20                 val os : SMLofNJ.SysInfo.os_kind
21                 val load_plugin : SrcPath.dir -> string -> bool) =
22    struct
23      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
24                                        val os = os)                                        val os = os)
25        structure P = OS.Path
26      (* Since the bootstrap compiler never executes any of the code      structure F = OS.FileSys
27       * it produces, we don't need any dynamic values.  Therefore,      structure BF = MachDepVC.Binfile
      * we create RecompPersstate (but not FullPersstate!) and  
      * instantiate Recomp as well as RecompTraversal.  
      * Since RecompPersstate is not part of any surrounding FullPersstate,  
      * function "discard_value" simply does nothing. *)  
     structure RecompPersstate =  
         RecompPersstateFn (structure MachDepVC = MachDepVC  
                            val discard_code = true  
                            fun discard_value (i: SmlInfo.info) = ())  
     structure Recomp = RecompFn (structure PS = RecompPersstate)  
     structure RT = CompileGenericFn (structure CT = Recomp)  
   
     fun recomp gp g = isSome (RT.group gp g)  
   
     (* instantiate Stabilize... *)  
     structure Stabilize =  
         StabilizeFn (fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))  
                      val getPid = RecompPersstate.pid_fetch_sml  
                      fun warmup (i, p) = ()  
                      val recomp = recomp)  
     (* ... and Parse *)  
     structure Parse = ParseFn (structure Stabilize = Stabilize)  
   
     fun compile { dirbase, pcmodespec, initgspec, maingspec, stabilize } = let  
28    
29          val arch = MachDepVC.architecture          val arch = MachDepVC.architecture
30          val osname = FilenamePolicy.kind2name os          val osname = FilenamePolicy.kind2name os
         val bindir = concat [dirbase, ".bin.", arch, "-", osname]  
         val bootdir = concat [dirbase, ".boot.", arch, "-", osname]  
31    
32          val keep_going = EnvConfig.getSet StdConfig.keep_going NONE      val archos = concat [arch, "-", osname]
33    
34        fun init_servers (GG.GROUP { grouppath, ... }) =
35            Servers.cmb { archos = archos,
36                          root = SrcPath.encode grouppath }
37          | init_servers GG.ERRORGROUP = ()
38    
39        structure StabModmap = StabModmapFn ()
40    
41        structure Compile = CompileFn (structure MachDepVC = MachDepVC
42                                       structure StabModmap = StabModmap
43                                       val useStream = useStream
44                                       val compile_there =
45                                           Servers.compile o SrcPath.encode)
46    
47        structure BFC = BfcFn (structure MachDepVC = MachDepVC)
48    
49          val ctxt = SrcPath.cwdContext ()      (* instantiate Stabilize... *)
50        structure Stabilize =
51            StabilizeFn (structure MachDepVC = MachDepVC
52                         structure StabModmap = StabModmap
53                         fun recomp gp g = let
54                             val { store, get } = BFC.new ()
55                             val _ = init_servers g
56                             val { group, ... } =
57                                 Compile.newTraversal (fn _ => fn _ => (),
58                                                       store, g)
59                         in
60                             case Servers.withServers (fn () => group gp) of
61                                 NONE => NONE
62                               | SOME _ => SOME get
63                         end
64                         val getII = Compile.getII)
65    
66          val pidfile = OS.Path.joinDirFile { dir = bootdir, file = "RTPID" }      structure VerifyStable = VerStabFn (structure Stabilize = Stabilize)
         val listfile = OS.Path.joinDirFile { dir = bootdir, file = "BINLIST" }  
67    
68          val pcmode = let      (* ... and Parse *)
69              fun work s = let      structure Parse = ParseFn (structure Stabilize = Stabilize
70                  fun loop l = let                                 structure StabModmap = StabModmap
71                      val line = TextIO.inputLine s                                 val evictStale = Compile.evictStale
72                                   fun pending () = SymbolMap.empty)
73    
74        fun mkBootList g = let
75            fun listName p =
76                case P.fromString p of
77                    { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
78                        fun win32name () =
79                            concat (arc1 ::
80                                    foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
81                  in                  in
82                      if line = "" then PathConfig.hardwire l                      case os of
83                      else case String.tokens Char.isSpace line of                          SMLofNJ.SysInfo.WIN32 => win32name ()
84                          [a, s] => loop ((a, s) :: l)                        | _ => P.toString { isAbs = false, vol = "",
85                        | _ => (Say.say [pcmodespec,                                            arcs = arc1 :: arcn }
                                        ": malformed line (ignored)\n"];  
                               loop l)  
86                  end                  end
87                  | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
88              in              in
89                  loop []          MkBootList.group listName g
90              end              end
91    
92        local
93            fun internal_reset () =
94                (Compile.reset ();
95                 Parse.reset ();
96                 StabModmap.reset ())
97          in          in
98              SafeIO.perform { openIt = fn () => TextIO.openIn pcmodespec,          fun reset () =
99                               closeIt = TextIO.closeIn,              (Say.vsay ["[CMB reset]\n"];
100                               work = work,               internal_reset ())
101                               cleanup = fn () => () }          val checkDirbase = let
102                val prev = ref NONE
103                fun ck db =
104                    (case !prev of
105                         NONE => prev := SOME db
106                       | SOME db' =>
107                         if db = db' then ()
108                         else (Say.vsay ["[new dirbase is `", db,
109                                         "'; CMB reset]\n"];
110                               internal_reset ();
111                               prev := SOME db))
112            in
113                ck
114            end
115          end          end
116    
117          fun stdpath s = SrcPath.standard pcmode { context = ctxt, spec = s }      fun mk_compile { deliver, root, dirbase = dbopt, paranoid } = let
118    
119          val initgspec = stdpath initgspec          val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
120          val maingspec = stdpath maingspec          val _ = checkDirbase dirbase
121            val penvspec = BtNames.penvspec
122            val initgspec = BtNames.initgspec
123            val maingspec = BtNames.maingspec
124    
125          val initfnpolicy =          val bindir = concat [dirbase, BtNames.bin_infix, archos]
126              FilenamePolicy.separate { bindir = bootdir, bootdir = bootdir }          val bootdir = concat [dirbase, BtNames.boot_infix, archos]
127                  { arch = arch, os = os }  
128            val keep_going = #get StdConfig.keep_going ()
129    
130            val ctxt = SrcPath.cwd ()
131    
132            val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
133            val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
134    
135            val penv = SrcPath.newEnv ()
136            val _ = SrcPath.processSpecFile (penv, penvspec)
137            val _ = SrcPath.sync ()
138    
139            fun stdpath s =
140                SrcPath.file (SrcPath.standard
141                                  { err = fn s => raise Fail s, env = penv }
142                                  { context = ctxt, spec = s })
143    
144            val initgspec = stdpath initgspec
145            val maingspec =
146                case root of
147                    NONE => stdpath maingspec
148                  | SOME r => SrcPath.decode penv r
149    
150          val mainfnpolicy =          val fnpolicy =
151              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
152                  { arch = arch, os = os }                  { arch = arch, os = os }
153    
154          fun mkParam { primconf, pervasive, pervcorepids, fnpolicy }          val param =
155                      { corenv } =              { fnpolicy = fnpolicy,
156              { primconf = primconf,                penv = penv,
157                fnpolicy = fnpolicy,                symval = SSV.symval,
158                pcmode = pcmode,                keep_going = keep_going }
               symenv = SSV.env,  
               keep_going = keep_going,  
               pervasive = pervasive,  
               corenv = corenv,  
               pervcorepids = pervcorepids }  
159    
160          val emptydyn = E.dynamicPart E.emptyEnv          val emptydyn = E.dynamicPart E.emptyEnv
161    
162          (* first, build an initial GeneralParam.info, so we can          (* first, build an initial GeneralParam.info, so we can
163           * 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 mkInitParam = mkParam { primconf = primconf,  
                                     pervasive = E.emptyEnv,  
                                     pervcorepids = PidSet.empty,  
                                     fnpolicy = initfnpolicy }  
   
         val param_nocore = mkInitParam { corenv = BE.staticPart BE.emptyEnv }  
164    
165          val groupreg = GroupReg.new ()          val groupreg = GroupReg.new ()
166          val errcons = EM.defaultConsumer ()          val errcons = EM.defaultConsumer ()
167          val ginfo_nocore = { param = param_nocore, groupreg = groupreg,          val ginfo = { param = param, groupreg = groupreg,
168                               errcons = errcons }                        errcons = errcons,
169                          youngest = ref TStamp.ancient }
170    
171          fun main_compile arg = let          fun mk_main_compile arg = let
             val { rts, core, pervasive, primitives, binpaths } = arg  
172    
173                val { pervasive = perv_n, others, src } = arg
174    
175                fun recompInitGroup () = let
176              val ovldR = GenericVC.Control.overloadKW              val ovldR = GenericVC.Control.overloadKW
177              val savedOvld = !ovldR              val savedOvld = !ovldR
178              val _ = ovldR := true              val _ = ovldR := true
179                    val sbnode = Compile.newSbnodeTraversal ()
180    
181              (* 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 (RT.snode ginfo_nocore core)  
             val corenv =  CoerceEnv.es2bs (#1 (#stat core))  
             val core_sym = #1 (#sym 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 (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  
   
             (* This 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 (#1 (#sym pervasive), core_sym)  
182    
183              val param =                  fun rt n = valOf (sbnode ginfo n)
184                  mkParam { primconf = Primitive.configuration pspecs,                  val pervasive = rt perv_n
185                            pervasive = E.mkenv { static = #1 (#stat pervasive),  
186                                                  symbolic = perv_sym,                  fun rt2ie (n, ii: IInfo.info) = let
187                                                  dynamic = emptydyn },                      val s = #statenv ii ()
188                            pervcorepids =                      val (dae, mkDomain) = Statenv2DAEnv.cvt s
189                              PidSet.addList (PidSet.empty,                      val domain = mkDomain ()
                                             [#2 (#stat pervasive),  
                                              #2 (#sym pervasive),  
                                              #2 (#stat core)]),  
                           fnpolicy = mainfnpolicy }  
                         { corenv = corenv }  
             val stableflag = if stabilize then SOME true else NONE  
190          in          in
191              case Parse.parse NONE param stableflag maingspec of                      { ie = (fn () => (NONE, n), dae, domain), domain = domain }
192                  NONE => false                  end
193                | SOME (g, gp) =>  
194                      if recomp gp g then let                  fun add_exports (n, exports) = let
195                          val rtspid = PS.toHex (#2 (#stat rts))                      val { ie, domain } = rt2ie (n, rt n)
196                          val bootfiles =                      fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
197                              map (fn x => (x, NONE)) binpaths @                  in
198                              MkBootList.group g                      SymbolSet.foldl ins_ie exports domain
199                          fun writeList s = let                  end
200                              fun offset NONE = ["\n"]  
201                                | offset (SOME i) = ["@", Int.toString i, "\n"]                  val special_exports = let
202                              fun showBootFile (p, off) =                      fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
203                                  TextIO.output (s, concat (p :: offset off))                  in
204                          in                      SymbolMap.insert (SymbolMap.empty,
205                              app showBootFile bootfiles                                        PervAccess.pervStrSym,
206                          end                                        mkie (perv_n, pervasive))
207                      in                  end
208                          Say.say ["Runtime System PID is: ", rtspid, "\n"];              in
209                          SafeIO.perform { openIt = fn () =>                  GG.GROUP { exports = foldl add_exports special_exports others,
210                                             AutoDir.openTextOut pidfile,                             kind = GG.LIB {
211                                           closeIt = TextIO.closeOut,                               kind = GG.DEVELOPED { wrapped = StringSet.empty,
212                                           work = fn s =>                                                     subgroups = [] },
213                                             TextIO.output (s, rtspid ^ "\n"),                                  version = NONE },
214                                           cleanup = fn () =>                             required = StringSet.singleton "primitive",
215                                             OS.FileSys.remove pidfile                             grouppath = initgspec,
216                                             handle _ => () };                             (* hack: sources never used for this group *)
217                          SafeIO.perform { openIt = fn () =>                             sources = SrcPathMap.empty,
218                               sublibs = [] }
219                    before (ovldR := savedOvld)
220                end
221    
222                (* just go and load the stable init group or signal failure *)
223                fun loadInitGroup () = let
224                    val lsarg =
225                        { getGroup = fn _ => raise Fail "CMB: initial getGroup",
226                          anyerrors = ref false }
227                in
228                    case Stabilize.loadStable lsarg (ginfo, initgspec, NONE, []) of
229                        NONE => NONE
230                      | SOME (g as GG.GROUP { exports, ... }) => SOME g
231                      | SOME GG.ERRORGROUP => NONE
232                end
233    
234                (* Don't try to load the stable init group. Instead, recompile
235                 * directly. *)
236                fun dontLoadInitGroup () = let
237                    val g0 = recompInitGroup ()
238                    val stabarg = { group = g0, anyerrors = ref false }
239                in
240                    if deliver then
241                        case Stabilize.stabilize ginfo stabarg of
242                            SOME g => g
243                          | NONE => raise Fail "CMB: cannot stabilize init group"
244                    else g0
245                end
246    
247                (* Try loading the init group from the stable file if possible;
248                 * recompile if loading fails *)
249                fun tryLoadInitGroup () =
250                    case loadInitGroup () of
251                        SOME g => g
252                      | NONE => dontLoadInitGroup ()
253    
254                (* Ok, now, based on "paranoid" and stable verification,
255                 * call the appropriate function(s) to get the init group. *)
256                val init_group =
257                    if paranoid then let
258                        val export_nodes = perv_n :: others
259                        val ver_arg = (initgspec, export_nodes, [],
260                                       SrcPathSet.empty, NONE)
261                        val em = StableMap.empty
262                    in
263                        if VerifyStable.verify' ginfo em ver_arg then
264                            tryLoadInitGroup ()
265                        else dontLoadInitGroup ()
266                    end
267                    else tryLoadInitGroup ()
268    
269    
270                val stab = if deliver then SOME true else NONE
271    
272                val gr = GroupReg.new ()
273                val _ = GroupReg.register gr (initgspec, src)
274    
275                val parse_arg =
276                    { load_plugin = load_plugin,
277                      gr = gr,
278                      param = param,
279                      stabflag = stab,
280                      group = maingspec,
281                      init_group = init_group,
282                      paranoid = paranoid }
283            in
284                Servers.dirbase dirbase;
285                Servers.cmb_new { archos = archos };
286                case Parse.parse parse_arg of
287                    NONE => NONE
288                  | SOME (g, gp) => let
289                        fun thunk () = let
290                            val _ = init_servers g
291                            fun store _ = ()
292                            val { group = recomp, ... } =
293                                Compile.newTraversal (fn _ => fn _ => (), store, g)
294                            val res =
295                                Servers.withServers (fn () => recomp gp)
296                        in
297                            if isSome res then let
298                                val { l = bootitems, ss } = mkBootList g
299                                val stablelibs = Reachable.stableLibsOf g
300                                fun inSet bi = StableSet.member (ss, bi)
301                                val frontiers =
302                                    SrcPathMap.map (Reachable.frontier inSet)
303                                                   stablelibs
304                                fun writeBootList s = let
305                                    fun wr str = TextIO.output (s, str ^ "\n")
306                                    val numitems = length bootitems
307                                    fun biggerlen (s, n) = Int.max (size s, n)
308                                    val maxlen = foldl biggerlen 0 bootitems
309                                in
310                                    wr (concat ["%", Int.toString numitems,
311                                                " ", Int.toString maxlen]);
312                                    app wr bootitems
313                                end
314                                fun writePid s i = let
315                                    val sn = BinInfo.stablename i
316                                    val os = BinInfo.offset i
317                                    val descr = BinInfo.describe i
318                                    val bfc = BFC.getStable
319                                        { stable = sn, offset = os, descr = descr }
320                                in
321                                    case BF.exportPidOf bfc of
322                                        NONE => ()
323                                      | SOME pid =>
324                                            (TextIO.output (s, " ");
325                                             TextIO.output (s, PS.toHex pid))
326                                end
327                                fun writePidLine s (p, set) =
328                                    if StableSet.isEmpty set then ()
329                                    else (TextIO.output (s, SrcPath.encode p);
330                                          StableSet.app (writePid s) set;
331                                          TextIO.output (s, "\n"))
332                                fun writePidMap s =
333                                    SrcPathMap.appi (writePidLine s) frontiers
334                            in
335                                if deliver then
336                                    (SafeIO.perform
337                                     { openIt = fn () =>
338                                             AutoDir.openTextOut listfile,                                             AutoDir.openTextOut listfile,
339                                           closeIt = TextIO.closeOut,                                           closeIt = TextIO.closeOut,
340                                           work = writeList,                                     work = writeBootList,
341                                           cleanup = fn () =>                                     cleanup = fn _ =>
342                                             OS.FileSys.remove listfile                                             OS.FileSys.remove listfile
343                                             handle _ => () };                                             handle _ => () };
344                                     SafeIO.perform
345                                     { openIt = fn () =>
346                                           AutoDir.openTextOut pidmapfile,
347                                       closeIt = TextIO.closeOut,
348                                       work = writePidMap,
349                                       cleanup = fn _ =>
350                                           OS.FileSys.remove pidmapfile
351                                           handle _ => () };
352                                     Say.say
353                                          ["New boot directory has been built.\n"])
354                                else ();
355                          true                          true
356                      end                      end
357                      else false                      else false
358          end handle Option => (RT.reset (); false)                      end
359                    in
360                        SOME ((g, gp, penv), thunk)
361                    end
362            end handle Option => (Compile.reset (); NONE)
363                     (* to catch valOf failures in "rt" *)                     (* to catch valOf failures in "rt" *)
364      in      in
365          case BuildInitDG.build ginfo_nocore initgspec of          case BuildInitDG.build ginfo initgspec of
366              SOME x => main_compile x              SOME x => mk_main_compile x
367            | NONE => false            | NONE => NONE
368        end
369    
370        fun compile dbopt =
371            (StabModmap.reset ();
372             case mk_compile { deliver = true, root = NONE,
373                               dirbase = dbopt, paranoid = true } of
374                 NONE => false
375               | SOME (_, thunk) => thunk ())
376    
377        local
378            fun slave NONE = (StabModmap.reset (); NONE)
379              | slave (SOME (dirbase, root)) =
380                case mk_compile { deliver = false, root = SOME root,
381                                  dirbase = SOME dirbase, paranoid = false } of
382                    NONE => NONE
383                  | SOME ((g, gp, penv), _) => let
384                        val trav = Compile.newSbnodeTraversal () gp
385                        fun trav' sbn = isSome (trav sbn)
386                    in
387                        SOME (g, trav', penv)
388      end      end
389        in
390            val _ = CMBSlaveHook.init archos slave
391        end
392    
393        val make' = compile
394        fun make () = make' NONE
395        val symval = SSV.symval
396  end  end
397    end (* local *)

Legend:
Removed from v.357  
changed lines
  Added in v.734

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