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 363, Fri Jul 2 02:45:45 1999 UTC revision 448, Thu Oct 21 09:20:16 1999 UTC
# Line 8  Line 8 
8   *)   *)
9  functor BootstrapCompileFn (structure MachDepVC: MACHDEP_VC  functor BootstrapCompileFn (structure MachDepVC: MACHDEP_VC
10                              val os: SMLofNJ.SysInfo.os_kind) :> sig                              val os: SMLofNJ.SysInfo.os_kind) :> sig
11      val recomp' : string option -> bool      val make' : string option -> bool
12      val recomp : unit -> bool      val make : unit -> bool
13      val deliver' : string option -> bool      val deliver' : string option -> bool
14      val deliver : unit -> bool      val deliver : unit -> bool
15      val reset : unit -> unit      val reset : unit -> unit
16        val symval : string -> { get: unit -> int option, set: int option -> unit }
17  end = struct  end = struct
18    
19      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
# Line 23  Line 24 
24      structure CoerceEnv = GenericVC.CoerceEnv      structure CoerceEnv = GenericVC.CoerceEnv
25      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC      structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
26                                        val os = os)                                        val os = os)
27        structure P = OS.Path
28        structure F = OS.FileSys
29        structure BF = MachDepVC.Binfile
30    
31      (* Since the bootstrap compiler never executes any of the code      structure Compile = CompileFn (structure MachDepVC = MachDepVC
32       * it produces, we don't need any dynamic values.  Therefore,                                     fun compile_there _ = false)
      * 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 stable_value_present i = false  
                            fun new_smlinfo i = ())  
33    
34      structure Recomp = RecompFn (structure PS = RecompPersstate)      structure BFC = BfcFn (structure MachDepVC = MachDepVC)
     structure RT = CompileGenericFn (structure CT = Recomp)  
   
     fun recomp gp g = isSome (RT.group gp g)  
35    
36      (* instantiate Stabilize... *)      (* instantiate Stabilize... *)
37      structure Stabilize =      structure Stabilize =
38          StabilizeFn (fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))          StabilizeFn (fun destroy_state _ i = Compile.evict i
39                       val getPid = RecompPersstate.pid_fetch_sml                       structure MachDepVC = MachDepVC
40                       fun warmup (i, p) = ()                       fun recomp gp g = let
41                       val recomp = recomp                           val { store, get } = BFC.new ()
42                       val transfer_state = RecompPersstate.transfer_state)                           val { group, ... } =
43                                 Compile.newTraversal (fn _ => fn _ => (),
44                                                       store, g)
45                         in
46                             case group gp of
47                                 NONE => NONE
48                               | SOME _ => SOME get
49                         end
50                         val getII = Compile.getII)
51    
52      (* ... and Parse *)      (* ... and Parse *)
53      structure Parse = ParseFn (structure Stabilize = Stabilize      structure Parse = ParseFn (structure Stabilize = Stabilize
54                                 val pending = AutoLoad.getPending)                                 fun pending () = SymbolMap.empty)
55    
56      fun listName p =      (* copying an input file to an output file safely... *)
57          case OS.Path.fromString p of      fun copyFile (oi, ci, oo, co, inp, outp, eof) (inf, outf) = let
58              { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let          fun workIn is = let
59                  fun win32name () =              fun workOut os = let
60                      concat (arc1 ::                  val N = 4096
61                              foldr (fn (a, r) => "\\" :: a :: r) [] arcn)                  fun loop () =
62                        if eof is then () else (outp (os, inp (is, N)); loop ())
63              in              in
64                  case os of                  loop ()
                     SMLofNJ.SysInfo.WIN32 => win32name ()  
                   | _ => OS.Path.toString { isAbs = false, vol = "",  
                                             arcs = arc1 :: arcn }  
65              end              end
66            | _ => raise Fail "BootstrapCompile:listName: bad name"          in
67                SafeIO.perform { openIt = fn () => oo outf,
68                                 closeIt = co,
69                                 work = workOut,
70                                 cleanup = fn () =>
71                                     (F.remove outf handle _ => ()) }
72            end
73        in
74            SafeIO.perform { openIt = fn () => oi inf,
75                             closeIt = ci,
76                             work = workIn,
77                             cleanup = fn () => () }
78        end
79    
80        val copyTextFile =
81            copyFile (TextIO.openIn, TextIO.closeIn,
82                      AutoDir.openTextOut, TextIO.closeOut,
83                      TextIO.inputN, TextIO.output, TextIO.endOfStream)
84    
85        val copyBinFile =
86            copyFile (BinIO.openIn, BinIO.closeIn,
87                      AutoDir.openBinOut, BinIO.closeOut,
88                      BinIO.inputN, BinIO.output, BinIO.endOfStream)
89    
90      fun compile deliver dbopt = let      fun compile deliver dbopt = let
91    
# Line 78  Line 99 
99          val bindir = concat [dirbase, ".bin.", arch, "-", osname]          val bindir = concat [dirbase, ".bin.", arch, "-", osname]
100          val bootdir = concat [dirbase, ".boot.", arch, "-", osname]          val bootdir = concat [dirbase, ".boot.", arch, "-", osname]
101    
102          val keep_going = EnvConfig.getSet StdConfig.keep_going NONE          fun listName (p, copy) =
103                case P.fromString p of
104                    { vol = "", isAbs = false, arcs = arc0 :: arc1 :: arcn } => let
105                        fun win32name () =
106                            concat (arc1 ::
107                                    foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
108                        fun doCopy () = let
109                            val bootpath =
110                                P.toString { isAbs = false, vol = "",
111                                             arcs = bootdir :: arc1 :: arcn }
112                        in
113                            copyBinFile (p, bootpath)
114                        end
115                    in
116                        if copy andalso arc0 = bindir then doCopy () else ();
117                        case os of
118                            SMLofNJ.SysInfo.WIN32 => win32name ()
119                          | _ => P.toString { isAbs = false, vol = "",
120                                              arcs = arc1 :: arcn }
121                    end
122                  | _ => raise Fail "BootstrapCompile:listName: bad name"
123    
124            val keep_going = #get StdConfig.keep_going ()
125    
126          val ctxt = SrcPath.cwdContext ()          val ctxt = SrcPath.cwdContext ()
127    
128          val pidfile = OS.Path.joinDirFile { dir = bootdir, file = "RTPID" }          val pidfile = P.joinDirFile { dir = bootdir, file = "RTPID" }
129          val listfile = OS.Path.joinDirFile { dir = bootdir, file = "BOOTLIST" }          val listfile = P.joinDirFile { dir = bootdir, file = "BOOTLIST" }
130    
131          val pcmode = PathConfig.new ()          val pcmode = PathConfig.new ()
132          val _ = PathConfig.processSpecFile (pcmode, pcmodespec)          val _ = PathConfig.processSpecFile (pcmode, pcmodespec)
# Line 96  Line 139 
139          val cmifile = valOf (SrcPath.reAnchoredName (initgspec, bootdir))          val cmifile = valOf (SrcPath.reAnchoredName (initgspec, bootdir))
140              handle Option => raise Fail "BootstrapCompile: cmifile"              handle Option => raise Fail "BootstrapCompile: cmifile"
141    
142          val initfnpolicy =          val fnpolicy =
             FilenamePolicy.separate { bindir = bootdir, bootdir = bootdir }  
                 { arch = arch, os = os }  
   
         val mainfnpolicy =  
143              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }              FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
144                  { arch = arch, os = os }                  { arch = arch, os = os }
145    
146          fun mkParam { primconf, pervasive, pervcorepids, fnpolicy }          fun mkParam { primconf, pervasive, pervcorepids }
147                      { corenv } =                      { corenv } =
148              { primconf = primconf,              { primconf = primconf,
149                fnpolicy = fnpolicy,                fnpolicy = fnpolicy,
150                pcmode = pcmode,                pcmode = pcmode,
151                symenv = SSV.env,                symval = SSV.symval,
152                keep_going = keep_going,                keep_going = keep_going,
153                pervasive = pervasive,                pervasive = pervasive,
154                corenv = corenv,                corenv = corenv,
# Line 123  Line 162 
162          val primconf = Primitive.primEnvConf          val primconf = Primitive.primEnvConf
163          val mkInitParam = mkParam { primconf = primconf,          val mkInitParam = mkParam { primconf = primconf,
164                                      pervasive = E.emptyEnv,                                      pervasive = E.emptyEnv,
165                                      pervcorepids = PidSet.empty,                                      pervcorepids = PidSet.empty }
                                     fnpolicy = initfnpolicy }  
166    
167          val param_nocore = mkInitParam { corenv = BE.staticPart BE.emptyEnv }          val param_nocore = mkInitParam { corenv = BE.staticPart BE.emptyEnv }
168    
# Line 139  Line 177 
177              val ovldR = GenericVC.Control.overloadKW              val ovldR = GenericVC.Control.overloadKW
178              val savedOvld = !ovldR              val savedOvld = !ovldR
179              val _ = ovldR := true              val _ = ovldR := true
180                val sbnode = Compile.newSbnodeTraversal ()
181    
182              (* here we build a new gp -- the one that uses the freshly              (* here we build a new gp -- the one that uses the freshly
183               * brewed pervasive env, core env, and primitives *)               * brewed pervasive env, core env, and primitives *)
184              val core = valOf (RT.sbnode ginfo_nocore core)              val core = valOf (sbnode ginfo_nocore core)
185              val corenv =  CoerceEnv.es2bs (#1 (#stat core))              val corenv =  CoerceEnv.es2bs (#statenv (#ii core) ())
186              val core_sym = #1 (#sym core)              val core_sym = #symenv (#ii core) ()
187    
188              (* The following is a bit of a hack (but corenv is a hack anyway):              (* The following is a bit of a hack (but corenv is a hack anyway):
189               * As soon as we have core available, we have to patch the               * As soon as we have core available, we have to patch the
# Line 154  Line 193 
193              val ginfo_justcore = { param = param_justcore, groupreg = groupreg,              val ginfo_justcore = { param = param_justcore, groupreg = groupreg,
194                                     errcons = errcons }                                     errcons = errcons }
195    
196              fun rt n = valOf (RT.sbnode ginfo_justcore n)              fun rt n = valOf (sbnode ginfo_justcore n)
197              val rts = rt rts              val rts = rt rts
198              val pervasive = rt pervasive              val pervasive = rt pervasive
199    
200              fun sn2pspec (name, n) = let              fun sn2pspec (name, n) = let
201                  val { stat = (s, sp), sym = (sy, syp), ctxt } = rt n                  val { ii = { statenv, symenv, statpid, sympid }, ctxt } = rt n
202                  val env =                  val env =
203                      E.mkenv { static = s, symbolic = sy, dynamic = emptydyn }                      E.mkenv { static = statenv (),
204                  val pidInfo = { statpid = sp, sympid = syp, ctxt = ctxt }                                symbolic = symenv (),
205                                  dynamic = emptydyn }
206                    val pidInfo =
207                        { statpid = statpid, sympid = sympid, ctxt = ctxt }
208              in              in
209                  { name = name, env = env, pidInfo = pidInfo }                  { name = name, env = env, pidInfo = pidInfo }
210              end              end
# Line 171  Line 213 
213    
214              val _ = ovldR := savedOvld              val _ = ovldR := savedOvld
215    
216              (* This is a hack but must be done for both the symbolic              (* The following is a hack but must be done for both the symbolic
217               * and later the dynamic part of the core environment:               * and later the dynamic part of the core environment:
218               * we must include these parts in the pervasive env. *)               * we must include these parts in the pervasive env. *)
219              val perv_sym = E.layerSymbolic (#1 (#sym pervasive), core_sym)              val perv_sym = E.layerSymbolic (#symenv (#ii pervasive) (),
220                                                core_sym)
221    
222              val param =              val param =
223                  mkParam { primconf = Primitive.configuration pspecs,                  mkParam { primconf = Primitive.configuration pspecs,
224                            pervasive = E.mkenv { static = #1 (#stat pervasive),                            pervasive = E.mkenv { static =
225                                                     #statenv (#ii pervasive) (),
226                                                  symbolic = perv_sym,                                                  symbolic = perv_sym,
227                                                  dynamic = emptydyn },                                                  dynamic = emptydyn },
228                            pervcorepids =                            pervcorepids =
229                              PidSet.addList (PidSet.empty,                              PidSet.addList (PidSet.empty,
230                                              [#2 (#stat pervasive),                                              [#statpid (#ii pervasive),
231                                               #2 (#sym pervasive),                                               #sympid (#ii pervasive),
232                                               #2 (#stat core)]),                                               #statpid (#ii core)]) }
                           fnpolicy = mainfnpolicy }  
233                          { corenv = corenv }                          { corenv = corenv }
234              val stab =              val stab =
235                  if deliver then SOME true else NONE                  if deliver then SOME true else NONE
236          in          in
237              case Parse.parse NONE param stab maingspec of              case Parse.parse NONE param stab maingspec of
238                  NONE => false                  NONE => false
239                | SOME (g, gp) =>                | SOME (g, gp) => let
240                      if recomp gp g then let                      fun store _ = ()
241                          val rtspid = PS.toHex (#2 (#stat rts))                      val { group = recomp, ... } =
242                          val bootfiles =                          Compile.newTraversal (fn _ => fn _ => (), store, g)
243                              map (fn x => (x, NONE)) binpaths @                  in
244                              MkBootList.group g                      if isSome (recomp gp) then let
245                            val rtspid = PS.toHex (#statpid (#ii rts))
246                          fun writeList s = let                          fun writeList s = let
247                              fun offset NONE = ["\n"]                              fun add ((p, flag), l) = let
248                                | offset (SOME i) = ["@", Int.toString i, "\n"]                                  val n = listName (p, true)
                             fun showBootFile (p, off) =  
                                 TextIO.output (s, concat (listName p ::  
                                                           offset off))  
249                          in                          in
250                              app showBootFile bootfiles                                  if flag then n :: l else l
251                          end                          end
252                          fun cpCMI (ins, outs) = let                              fun transcribe (p, NONE) = listName (p, true)
253                              val N = 4096                                | transcribe (p, SOME (off, desc)) =
254                              fun cp () =                                  concat [listName (p, false),
255                                  if TextIO.endOfStream ins then ()                                          "@", Int.toString off, ":", desc]
256                                  else (TextIO.output (outs,                              val bootstrings =
257                                                       TextIO.inputN (ins, N));                                  foldr add (map transcribe (MkBootList.group g))
258                                        cp ())                                        binpaths
259                                fun show str =
260                                    (TextIO.output (s, str);
261                                     TextIO.output (s, "\n"))
262                          in                          in
263                              cp ()                              app show bootstrings
264                          end                          end
265                      in                      in
                       Say.say ["Runtime System PID is: ", rtspid, "\n"];  
266                        if deliver then                        if deliver then
267                         (SafeIO.perform { openIt = fn () =>                         (SafeIO.perform { openIt = fn () =>
268                                             AutoDir.openTextOut pidfile,                                             AutoDir.openTextOut pidfile,
# Line 236  Line 279 
279                                           cleanup = fn () =>                                           cleanup = fn () =>
280                                             OS.FileSys.remove listfile                                             OS.FileSys.remove listfile
281                                             handle _ => () };                                             handle _ => () };
282                          SafeIO.perform { openIt = fn () =>                          copyTextFile (SrcPath.osstring initgspec, cmifile);
283                                             (SrcPath.openTextIn initgspec,                          Say.say ["Runtime System PID is: ", rtspid, "\n"])
                                             AutoDir.openTextOut cmifile),  
                                          closeIt = fn (ins, outs) =>  
                                            (TextIO.closeIn ins;  
                                             TextIO.closeOut outs),  
                                          work = cpCMI,  
                                          cleanup = fn () =>  
                                            OS.FileSys.remove cmifile  
                                            handle _ => () })  
284                        else ();                        else ();
285                        true                        true
286                      end                      end
287                      else false                      else false
288          end handle Option => (RT.reset (); false)                  end
289            end handle Option => (Compile.reset (); false)
290                     (* to catch valOf failures in "rt" *)                     (* to catch valOf failures in "rt" *)
291      in      in
292          case BuildInitDG.build ginfo_nocore initgspec of          case BuildInitDG.build ginfo_nocore initgspec of
# Line 258  Line 294 
294            | NONE => false            | NONE => false
295      end      end
296    
     val recomp' = compile false  
     fun recomp () = recomp' NONE  
     val deliver' = compile true  
     fun deliver () = deliver' NONE  
297      fun reset () =      fun reset () =
298          (RecompPersstate.reset ();          (Compile.reset ();
299           RT.resetAll ();           Parse.reset ())
300           Recomp.reset ())  
301        val make' = compile false
302        fun make () = make' NONE
303        fun deliver' arg =
304            SafeIO.perform { openIt = fn () => (),
305                             closeIt = reset,
306                             work = fn () => compile true arg,
307                             cleanup = fn () => () }
308        fun deliver () = deliver' NONE
309        val symval = SSV.symval
310  end  end

Legend:
Removed from v.363  
changed lines
  Added in v.448

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