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 666, Fri Jun 16 08:27:00 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) = 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 os : SMLofNJ.SysInfo.os_kind
20       * Since RecompPersstate is not part of any surrounding FullPersstate,               val load_plugin : SrcPath.dir -> string -> bool) :> sig
21       * function "discard_value" simply does nothing. *)      val make' : string option -> bool
22      structure RecompPersstate =      val make : unit -> bool
23          RecompPersstateFn (structure MachDepVC = MachDepVC      val reset : unit -> unit
24                             val discard_code = true      val symval : string -> { get: unit -> int option, set: int option -> unit }
25                             fun discard_value (i: SmlInfo.info) = ())  end = struct
26      structure Recomp = RecompFn (structure PS = RecompPersstate)      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
27      structure RT = CompileGenericFn (structure CT = Recomp)                                        val os = os)
28        structure P = OS.Path
29        structure F = OS.FileSys
30        structure BF = MachDepVC.Binfile
31    
32        val arch = MachDepVC.architecture
33        val osname = FilenamePolicy.kind2name os
34    
35        val archos = concat [arch, "-", osname]
36    
37        fun init_servers (GG.GROUP { grouppath, ... }) =
38            Servers.cmb { archos = archos,
39                          root = SrcPath.encode grouppath }
40          | init_servers GG.ERRORGROUP = ()
41    
42        structure StabModmap = StabModmapFn ()
43    
44        structure Compile = CompileFn (structure MachDepVC = MachDepVC
45                                       structure StabModmap = StabModmap
46                                       val compile_there =
47                                           Servers.compile o SrcPath.encode)
48    
49      fun recomp gp g = isSome (RT.group gp g)      structure BFC = BfcFn (structure MachDepVC = MachDepVC)
50    
51      (* instantiate Stabilize... *)      (* instantiate Stabilize... *)
52      structure Stabilize =      structure Stabilize =
53          StabilizeFn (fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))          StabilizeFn (structure MachDepVC = MachDepVC
54                       val recomp = recomp)                       structure StabModmap = StabModmap
55      (* ... and Parse *)                       fun recomp gp g = let
56      structure Parse = ParseFn (structure Stabilize = Stabilize)                           val { store, get } = BFC.new ()
57                             val _ = init_servers g
58      fun compile { binroot, pcmodespec, initgspec, maingspec } = let                           val { group, ... } =
59                                 Compile.newTraversal (fn _ => fn _ => (),
60          val keep_going = EnvConfig.getSet StdConfig.keep_going NONE                                                     store, g)
61                         in
62          val ctxt = AbsPath.cwdContext ()                           case Servers.withServers (fn () => group gp) of
63                                 NONE => NONE
64                               | SOME _ => SOME get
65                         end
66                         val getII = Compile.getII)
67    
68          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 }  
69    
70          fun build_pcmode () = let      (* ... and Parse *)
71              val s = AbsPath.openTextIn pcmodespec      structure Parse = ParseFn (structure Stabilize = Stabilize
72              fun loop l = let                                 structure StabModmap = StabModmap
73                  val line = TextIO.inputLine s                                 val evictStale = Compile.evictStale
74                                   fun pending () = SymbolMap.empty)
75    
76        fun mkBootList g = let
77            fun listName p =
78                case P.fromString p of
79                    { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
80                        fun win32name () =
81                            concat (arc1 ::
82                                    foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
83              in              in
84                  if line = "" then PathConfig.hardwire l                      case os of
85                  else case String.tokens Char.isSpace line of                          SMLofNJ.SysInfo.WIN32 => win32name ()
86                      [a, s] => loop ((a, s) :: l)                        | _ => P.toString { isAbs = false, vol = "",
87                    | _ => (Say.say [AbsPath.name pcmodespec,                                            arcs = arc1 :: arcn }
                                    ": malformed line (ignored)\n"];  
                           loop l)  
88              end              end
89                  | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
90          in          in
91              loop [] before TextIO.closeIn s          MkBootList.group listName g
92          end          end
93    
94          val pcmode = build_pcmode ()      local
95            fun internal_reset () =
96                (Compile.reset ();
97                 Parse.reset ();
98                 StabModmap.reset ())
99        in
100            fun reset () =
101                (Say.vsay ["[CMB reset]\n"];
102                 internal_reset ())
103            val checkDirbase = let
104                val prev = ref NONE
105                fun ck db =
106                    (case !prev of
107                         NONE => prev := SOME db
108                       | SOME db' =>
109                         if db = db' then ()
110                         else (Say.vsay ["[new dirbase is `", db,
111                                         "'; CMB reset]\n"];
112                               internal_reset ();
113                               prev := SOME db))
114            in
115                ck
116            end
117        end
118    
119        fun mk_compile { deliver, root, dirbase = dbopt, paranoid } = let
120    
121            val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
122            val _ = checkDirbase dirbase
123            val penvspec = BtNames.penvspec
124            val initgspec = BtNames.initgspec
125            val maingspec = BtNames.maingspec
126    
127            val bindir = concat [dirbase, BtNames.bin_infix, archos]
128            val bootdir = concat [dirbase, BtNames.boot_infix, archos]
129    
130            val keep_going = #get StdConfig.keep_going ()
131    
132            val ctxt = SrcPath.cwd ()
133    
134            val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
135            val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
136    
137            val penv = SrcPath.newEnv ()
138            val _ = SrcPath.processSpecFile (penv, penvspec)
139    
140            fun stdpath s =
141                SrcPath.file (SrcPath.standard
142                                  { err = fn s => raise Fail s, env = penv }
143                                  { context = ctxt, spec = s })
144    
145            val initgspec = stdpath initgspec
146            val maingspec =
147                case root of
148                    NONE => stdpath maingspec
149                  | SOME r => SrcPath.decode penv r
150    
151          val fnpolicy =          val fnpolicy =
152              FilenamePolicy.separate { root = binroot,              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
153                                        parentArc = "DOTDOT",                  { arch = arch, os = os }
154                                        absArc = "ABSOLUTE" }  
155                                      { arch = MachDepVC.architecture, os = os }          val param =
156                { fnpolicy = fnpolicy,
157                  penv = penv,
158                  symval = SSV.symval,
159                  keep_going = keep_going }
160    
161          val emptydyn = E.dynamicPart E.emptyEnv          val emptydyn = E.dynamicPart E.emptyEnv
162    
163          (* first, build an initial GeneralParam.info, so we can          (* first, build an initial GeneralParam.info, so we can
164           * 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 }  
165    
166          val groupreg = GroupReg.new ()          val groupreg = GroupReg.new ()
167          val errcons = EM.defaultConsumer ()          val errcons = EM.defaultConsumer ()
168          val ginfo_nocore = { param = param_nocore, groupreg = groupreg,          val ginfo = { param = param, groupreg = groupreg, errcons = errcons }
                              errcons = errcons }  
169    
170          fun main_compile arg = let          fun mk_main_compile arg = let
             val { rts, core, pervasive, primitives, binpaths } = arg  
171    
172                val { pervasive = perv_n, others, src } = 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 ginfo n)
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              (* here we build a new gp -- the one that uses the freshly                  val special_exports = let
201               * brewed pervasive env, core env, and primitives *)                      fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
             val core = valOf (RT.snode ginfo_nocore core)  
             val corenv =  CoerceEnv.es2bs (#1 (#stat core))  
             (* even though we have a pid for the core, we can't use it  
              * (otherwise we would invalidate earlier compilation results) *)  
             val pervcorepids = PidSet.empty  
   
             (* 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 = { primconf = primconf,  
                                    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)]) }  
202          in          in
203              case Parse.parse param NONE maingspec of                      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                  NONE => NONE
229                | SOME (g, gp) =>                    | SOME (g as GG.GROUP { exports, ... }) => SOME g
230                      if recomp gp g then                    | SOME GG.ERRORGROUP => NONE
231                          SOME { rtspid = PS.toHex (#2 (#stat rts)),              end
232                                 bootfiles =  
233                                   map (fn x => (x, NONE)) binpaths @              (* Don't try to load the stable init group. Instead, recompile
234                                   MkBootList.group g }               * directly. *)
235                      else NONE              fun dontLoadInitGroup () = let
236          end handle Option => (RT.clearFailures (); NONE)                  val g0 = recompInitGroup ()
237                    val stabarg = { group = g0, anyerrors = ref false }
238                in
239                    if deliver then
240                        case Stabilize.stabilize ginfo stabarg of
241                            SOME g => g
242                          | NONE => raise Fail "CMB: cannot stabilize init group"
243                    else g0
244                end
245    
246                (* Try loading the init group from the stable file if possible;
247                 * recompile if loading fails *)
248                fun tryLoadInitGroup () =
249                    case loadInitGroup () of
250                        SOME g => g
251                      | NONE => dontLoadInitGroup ()
252    
253                (* Ok, now, based on "paranoid" and stable verification,
254                 * call the appropriate function(s) to get the init group. *)
255                val init_group =
256                    if paranoid then let
257                        val export_nodes = perv_n :: others
258                        val ver_arg = (initgspec, export_nodes, [],
259                                       SrcPathSet.empty, NONE)
260                        val em = StableMap.empty
261                    in
262                        if VerifyStable.verify' ginfo em ver_arg then
263                            tryLoadInitGroup ()
264                        else dontLoadInitGroup ()
265                    end
266                    else tryLoadInitGroup ()
267    
268    
269                val stab = if deliver then SOME true else NONE
270    
271                val gr = GroupReg.new ()
272                val _ = GroupReg.register gr (initgspec, src)
273    
274                val parse_arg =
275                    { load_plugin = load_plugin,
276                      gr = gr,
277                      param = param,
278                      stabflag = stab,
279                      group = maingspec,
280                      init_group = init_group,
281                      paranoid = paranoid }
282            in
283                Servers.dirbase dirbase;
284                Servers.cmb_new { archos = archos };
285                case Parse.parse parse_arg of
286                    NONE => NONE
287                  | SOME (g, gp) => let
288                        fun thunk () = let
289                            val _ = init_servers g
290                            fun store _ = ()
291                            val { group = recomp, ... } =
292                                Compile.newTraversal (fn _ => fn _ => (), store, g)
293                            val res =
294                                Servers.withServers (fn () => recomp gp)
295                        in
296                            if isSome res then let
297                                val { l = bootitems, ss } = mkBootList g
298                                val stablelibs = Reachable.stableLibsOf g
299                                fun inSet bi = StableSet.member (ss, bi)
300                                val frontiers =
301                                    SrcPathMap.map (Reachable.frontier inSet)
302                                                   stablelibs
303                                fun writeBootList s = let
304                                    fun wr str = TextIO.output (s, str ^ "\n")
305                                    val numitems = length bootitems
306                                    fun biggerlen (s, n) = Int.max (size s, n)
307                                    val maxlen = foldl biggerlen 0 bootitems
308                                in
309                                    wr (concat ["%", Int.toString numitems,
310                                                " ", Int.toString maxlen]);
311                                    app wr bootitems
312                                end
313                                fun writePid s i = let
314                                    val sn = BinInfo.stablename i
315                                    val os = BinInfo.offset i
316                                    val descr = BinInfo.describe i
317                                    val bfc = BFC.getStable
318                                        { stable = sn, offset = os, descr = descr }
319                                in
320                                    case BF.exportPidOf bfc of
321                                        NONE => ()
322                                      | SOME pid =>
323                                            (TextIO.output (s, " ");
324                                             TextIO.output (s, PS.toHex pid))
325                                end
326                                fun writePidLine s (p, set) =
327                                    if StableSet.isEmpty set then ()
328                                    else (TextIO.output (s, SrcPath.encode p);
329                                          StableSet.app (writePid s) set;
330                                          TextIO.output (s, "\n"))
331                                fun writePidMap s =
332                                    SrcPathMap.appi (writePidLine s) frontiers
333                            in
334                                if deliver then
335                                    (SafeIO.perform
336                                     { openIt = fn () =>
337                                           AutoDir.openTextOut listfile,
338                                       closeIt = TextIO.closeOut,
339                                       work = writeBootList,
340                                       cleanup = fn _ =>
341                                           OS.FileSys.remove listfile
342                                           handle _ => () };
343                                     SafeIO.perform
344                                     { openIt = fn () =>
345                                           AutoDir.openTextOut pidmapfile,
346                                       closeIt = TextIO.closeOut,
347                                       work = writePidMap,
348                                       cleanup = fn _ =>
349                                           OS.FileSys.remove pidmapfile
350                                           handle _ => () };
351                                     Say.say
352                                          ["New boot directory has been built.\n"])
353                                else ();
354                                true
355                            end
356                            else false
357                        end
358                    in
359                        SOME ((g, gp, penv), thunk)
360                    end
361            end handle Option => (Compile.reset (); NONE)
362                     (* to catch valOf failures in "rt" *)                     (* to catch valOf failures in "rt" *)
363      in      in
364          case BuildInitDG.build ginfo_nocore initgspec of          case BuildInitDG.build ginfo initgspec of
365              SOME x => main_compile x              SOME x => mk_main_compile x
366            | NONE => NONE            | NONE => NONE
367      end      end
368    
369        fun compile dbopt =
370            (StabModmap.reset ();
371             case mk_compile { deliver = true, root = NONE,
372                               dirbase = dbopt, paranoid = true } of
373                 NONE => false
374               | SOME (_, thunk) => thunk ())
375    
376        local
377            fun slave NONE = (StabModmap.reset (); NONE)
378              | slave (SOME (dirbase, root)) =
379                case mk_compile { deliver = false, root = SOME root,
380                                  dirbase = SOME dirbase, paranoid = false } of
381                    NONE => NONE
382                  | SOME ((g, gp, penv), _) => let
383                        val trav = Compile.newSbnodeTraversal () gp
384                        fun trav' sbn = isSome (trav sbn)
385                    in
386                        SOME (g, trav', penv)
387                    end
388        in
389            val _ = CMBSlaveHook.init archos slave
390        end
391    
392        val make' = compile
393        fun make () = make' NONE
394        val symval = SSV.symval
395  end  end
396    end (* local *)

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

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