Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/system/smlnj/installer/libinstall.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/smlnj/installer/libinstall.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1485 - (view) (download)

1 : mblume 1391 (* SML/NJ installer script -- written in SML.
2 :     * This script runs after the runtime system has been built and
3 :     * the interactive system has been booted from bootfiles.
4 :     *
5 :     * The remainder of the build process compiles additional libraries
6 :     * and installs certain standalone programs such as ml-yacc and ml-lex.
7 :     * This is the bulk of what used to be done by install.sh.
8 :     *
9 :     * The script is written in such a way that it can be used portably
10 :     * on both *nix- and win32-systems.
11 :     *
12 :     * (C) 2003 The Fellowship of SML/NJ
13 :     *
14 :     * Author: Matthias Blume (blume@tti-c.org)
15 :     *)
16 :     structure LibInstall : sig
17 :    
18 :     (* all filenames that are passed as arguments use native syntax: *)
19 :     val proc :
20 :     { smlnjroot: string,
21 : mblume 1409 installdir: string,
22 : mblume 1391 buildcmd: string,
23 :     instcmd : string -> unit,
24 :     unpackcmd: string option } -> unit
25 :    
26 :     end = struct
27 :    
28 :     structure P = OS.Path
29 :     structure F = OS.FileSys
30 :     structure SI = SMLofNJ.SysInfo
31 :     structure SM = RedBlackMapFn (type ord_key = string
32 :     val compare = String.compare)
33 : mblume 1485 structure SS = RedBlackSetFn (type ord_key = string
34 :     val compare = String.compare)
35 : mblume 1391
36 :     structure SCC = GraphSCCFn (type ord_key = string
37 :     val compare = String.compare)
38 :    
39 :     fun say l = TextIO.output (TextIO.stdErr, concat l)
40 : mblume 1411 fun warn l = say ("WARNING: " :: l)
41 : mblume 1391 fun fail l = (say ("FAILURE: " :: l);
42 :     OS.Process.exit OS.Process.failure)
43 :    
44 :     (* figure out who and what we are *)
45 :     val arch = String.map Char.toLower (SMLofNJ.SysInfo.getHostArch ())
46 :     val (isUnix, oskind) = case SI.getOSKind () of
47 :     SI.UNIX => (true, "unix")
48 :     | SI.WIN32 => (false, "win32")
49 :     | _ => fail ["os kind not supported\n"]
50 :    
51 :     val arch_oskind = concat [arch, "-", oskind]
52 :     val heap_suffix = SMLofNJ.SysInfo.getHeapSuffix ()
53 :    
54 :     (* File names in configuration files are used across all platforms
55 :     * and for that reason are written using CM's standard syntax
56 :     * which is like Unix pathname syntax. *)
57 :    
58 :     (* standard arc separator is / *)
59 :     fun usep #"/" = true
60 :     | usep _ = false
61 :    
62 :     (* convert standard syntax to native syntax *)
63 :     fun native f =
64 :     case String.fields usep f of
65 :     "" :: arcs => P.toString { vol = "", isAbs = true, arcs = arcs }
66 :     | arcs => P.toString { vol = "", isAbs = false, arcs = arcs }
67 :    
68 :     fun fexists f = F.access (f, []) handle _ => false
69 :    
70 :     fun rmfile f = F.remove f handle _ => ()
71 :    
72 :     (* several worklists for delayed execution *)
73 :     val stablist : (unit -> bool) list ref = ref []
74 :     val movlist : (unit -> unit) list ref = ref []
75 :     val salist : (unit -> unit) list ref = ref []
76 :    
77 :     (* make a directory (including parent, parent's parent, ...) *)
78 :     fun mkdir "" = ()
79 :     | mkdir d = if fexists d then () else (mkdir (P.dir d); F.mkDir d)
80 :    
81 :     (* move a stable library file to its final location *)
82 :     fun movelib src dst () =
83 :     (mkdir (P.dir dst); F.rename { old = src, new = dst })
84 :    
85 :     (* register a temporary anchor-value binding *)
86 :     fun localanchor { anchor, path } =
87 :     #set (CM.Anchor.anchor anchor) (SOME (native path))
88 :    
89 :     fun getInputTokens s =
90 :     Option.map (String.tokens Char.isSpace) (TextIO.inputLine s)
91 :    
92 :     (* Take a list of modules and dependencies (in depfile) and
93 :     * build the transitive closure of those modules.
94 :     * We do this by considering the dependency graph and construct
95 :     * a topological order for it. *)
96 :     fun resolve (modules, depfile) = let
97 :     val s = TextIO.openIn depfile
98 :     fun rd m =
99 :     case getInputTokens s of
100 :     NONE => (TextIO.closeIn s; fn x => getOpt (SM.find (m, x), []))
101 :     | SOME (x :: xs) => rd (SM.insert (m, x, xs))
102 :     | SOME [] => rd m
103 :     fun strip (SCC.SIMPLE c) = c
104 :     | strip _ = fail ["cyclic dependencies in ", depfile, "\n"]
105 :     in
106 :     rev (map strip (SCC.topOrder' { roots = modules,
107 :     follow = rd SM.empty }))
108 :     end
109 :    
110 :     (* do all the delayed stuff: *)
111 :    
112 :     (* stabilization of libraries... *)
113 :     fun dostabs () =
114 :     foldr (fn (f, true) => f () | (_, false) => false) true (!stablist)
115 :    
116 :     (* move stable library files to their final locations... *)
117 :     fun domoves () =
118 :     (app (fn f => f ()) (rev (!movlist)); true)
119 :     handle _ => false
120 :    
121 :     (* build those standalone programs that require libraries
122 :     * and, therefore, must be compiled "late"... *)
123 :     fun dolatesas () =
124 :     (app (fn f => f ()) (rev (!salist)); true)
125 :     handle _ => false
126 :    
127 :     (* our main routine *)
128 : mblume 1409 fun proc { smlnjroot, installdir, buildcmd, instcmd, unpackcmd } = let
129 : mblume 1391 val smlnjroot = F.fullPath smlnjroot
130 : mblume 1409 val installdir = F.fullPath installdir
131 : mblume 1391 val configdir = P.concat (smlnjroot, "config")
132 :    
133 :     (* dependency file: config/dependencies *)
134 :     val depfile = P.concat (configdir, "dependencies")
135 :    
136 :     (* find and open first usable targetsfiles *)
137 :     val targetsfiles =
138 :     [P.concat (configdir, "targets.customized"),
139 :     P.concat (configdir, "targets")]
140 :    
141 : mblume 1485 val allsrcfile = P.concat (configdir, "allsources")
142 :    
143 : mblume 1391 val s =
144 :     case List.find fexists targetsfiles of
145 :     SOME f => TextIO.openIn f
146 :     | NONE => fail ["no targetsfiles\n"]
147 :    
148 :     (* parse the targets file *)
149 : mblume 1485 fun loop (ml, allsrc) =
150 : mblume 1391 case TextIO.inputLine s of
151 : mblume 1485 NONE => (TextIO.closeIn s; (ml, allsrc))
152 : mblume 1391 | SOME l =>
153 : mblume 1485 if String.sub (l, 0) = #"#" then loop (ml, allsrc)
154 : mblume 1391 else (case String.tokens Char.isSpace l of
155 : mblume 1411 [x as ("dont_move_libraries" |
156 :     "move_libraries")] =>
157 :     (warn ["\"", x, "\" no longer supported",
158 :     " (installer always moves libraries)\n"];
159 : mblume 1485 loop (ml, allsrc))
160 :     | ["request", "src-smlnj"] => loop (ml, true)
161 :     | ["request", module] => loop (module :: ml, allsrc)
162 :     | [] => loop (ml, allsrc)
163 : mblume 1391 | _ => fail ["ill-formed targets line: ", l])
164 :    
165 : mblume 1485 val (modules, allsrc) = loop ([], false)
166 : mblume 1391
167 :     (* now resolve dependencies; get full list of modules
168 :     * in correct build order: *)
169 :     val modules = resolve (modules, depfile)
170 :    
171 : mblume 1485 val moduleset = SS.addList (SS.empty, modules)
172 :    
173 :     val srcmoduleset =
174 :     if allsrc andalso fexists allsrcfile then
175 :     let val s = TextIO.openIn allsrcfile
176 :     fun one (m, ms) =
177 :     if SS.member (ms, m) then ms else SS.add (ms, m)
178 :     fun loop ms =
179 :     case TextIO.inputLine s of
180 :     NONE => (TextIO.closeIn s; ms)
181 :     | SOME l =>
182 :     if String.sub (l, 0) = #"#" then loop ms
183 :     else loop (foldl one ms
184 :     (String.tokens Char.isSpace l))
185 :     in
186 :     loop moduleset
187 :     end
188 :     else moduleset
189 :    
190 : mblume 1391 (* fetch and unpack source trees, using auxiliary helper command
191 :     * which takes the root directory as its first and the module
192 :     * names to be fetched as subsequent arguments. *)
193 :     val _ = case unpackcmd of
194 :     NONE => () (* archives must exist *)
195 :     | SOME cmd => let
196 :     val cmdline =
197 :     concat (cmd :: " " :: smlnjroot :: " " ::
198 : mblume 1485 SS.foldl (fn (f, l) => " " :: f :: l)
199 :     [] srcmoduleset)
200 : mblume 1391 in
201 :     if OS.Process.system cmdline = OS.Process.success
202 :     then ()
203 :     else fail ["unpacking failed\n"]
204 :     end
205 :    
206 : mblume 1409 val libdir = P.concat (installdir, "lib")
207 : mblume 1391 val srcdir = P.concat (smlnjroot, "src")
208 : mblume 1409 val bindir = P.concat (installdir, "bin")
209 : mblume 1391 val heapdir = P.concat (bindir, ".heap")
210 :     val cm_pathconfig = P.concat (libdir, "pathconfig")
211 :    
212 :     (* add an entry to lib/pathconfig *)
213 :     fun write_cm_pathconfig (a, p) = let
214 :     val s = TextIO.openAppend cm_pathconfig
215 :     in
216 :     TextIO.output (s, concat [a, " ", p, "\n"])
217 :     before TextIO.closeOut s
218 :     end
219 :    
220 :     (* at the end, read lib/pathconfig and eliminate duplicate entries *)
221 :     fun uniqconfig () = let
222 :     fun finish m = let
223 :     val s = TextIO.openOut cm_pathconfig
224 :     fun one (key, value) =
225 :     TextIO.output (s, concat [key, " ", value, "\n"])
226 :     in
227 :     SM.appi one m; TextIO.closeOut s
228 :     end
229 :     val s = TextIO.openIn cm_pathconfig
230 :     fun loop m =
231 :     case getInputTokens s of
232 :     NONE => (TextIO.closeIn s; finish m)
233 :     | SOME [key, value] => loop (SM.insert (m, key, value))
234 :     | SOME l => (say ("funny line in " :: cm_pathconfig :: ":" ::
235 :     foldr (fn (x, l) => " " :: x :: l)
236 :     ["\n"] l);
237 :     loop m)
238 :     in
239 :     loop SM.empty
240 :     end
241 :    
242 :     (* register library to be built *)
243 :     fun reglib { anchor, altanchor, relname, dir } = let
244 :     (* anchor: the anchor name currently used by the library
245 :     * to be registered for compilation
246 :     * altanchor: optional alternative anchor name which is
247 :     * to be used once the library is in its final location
248 :     * (this must be used if "anchor" is already bound
249 :     * and used for other libraries which come from the
250 :     * bootfile bundle),
251 :     * relname: path to library's .cm file relative to anchor
252 :     * (standard syntax)
253 :     * dir: directory name that anchor should be bound to,
254 :     * name is relative to srcdir and in standard syntax *)
255 :     val nrelname = native relname
256 :     val ndir = native dir
257 :     val libname = concat ["$", anchor, "/", relname]
258 :     val adir = P.concat (srcdir, ndir)
259 :     val finalanchor = getOpt (altanchor, anchor)
260 :     val { dir = nreldir, file = relbase } = P.splitDirFile nrelname
261 :     val relloc =
262 :     P.concat (nreldir, P.concat (CM.cm_dir_arc,
263 :     P.concat (arch_oskind, relbase)))
264 :     val srcfinalloc = P.concat (adir, relloc)
265 :     val (finalloc, finalconfigpath) =
266 : mblume 1411 (P.concat (libdir,
267 : mblume 1391 P.concat (finalanchor, relloc)),
268 :     finalanchor)
269 :     in
270 :     if fexists finalloc then
271 :     (say ["Library ", libname, " already existed in ",
272 :     finalloc, ". Will rebuild.\n"];
273 :     rmfile finalloc)
274 :     else ();
275 :     if fexists srcfinalloc then rmfile srcfinalloc else ();
276 :     if not (fexists (P.concat (adir, nrelname))) then
277 :     fail ["Source tree for ", libname, " at ",
278 :     P.concat (adir, nreldir), "(", relbase,
279 :     ") does not exist.\n"]
280 :     else
281 :     (say ["Scheduling library ", libname, " to be built as ",
282 :     finalloc, "\n"];
283 :     stablist := (fn () => CM.stabilize false libname)
284 :     :: !stablist;
285 :     #set (CM.Anchor.anchor anchor) (SOME adir);
286 : mblume 1411 movlist := movelib srcfinalloc finalloc :: !movlist;
287 : mblume 1391 write_cm_pathconfig (finalanchor, finalconfigpath))
288 :     end
289 :    
290 :     (* build a standalone program, using auxiliary build script *)
291 :     fun standalone { target, optheapdir, optsrcdir } = let
292 :     (* target: name of program; this is the same as the basename
293 :     * of the heap image to be generated as well as the
294 :     * final arc of the source tree's directory name
295 :     * optheapdir: optional subdirectory where the build command
296 :     * drops the heap image
297 :     * optsrcdir:
298 :     * The source tree for target is located in a directory
299 :     * named the same as the target itself. Normally it is
300 :     * a subdirectory of srcdir. With optsrcdir one can specify
301 :     * an alternative for srcdir by giving a path relative to
302 :     * the original srcdir. *)
303 :     val heapname = concat [target, ".", heap_suffix]
304 :     val targetheaploc =
305 :     case optheapdir of
306 :     NONE => heapname
307 :     | SOME hd => P.concat (native hd, heapname)
308 :     val mysrcdir =
309 :     case optsrcdir of
310 :     NONE => srcdir
311 :     | SOME sd => P.concat (srcdir, native sd)
312 :     val finalheaploc = P.concat (heapdir, heapname)
313 :     val treedir = P.concat (mysrcdir, target)
314 :     in
315 :     if fexists finalheaploc then
316 :     say ["Target ", target, " already exists.\n"]
317 :     else if not (fexists treedir) then
318 :     fail ["Source tree for ", target, " at ", treedir,
319 :     " does not exist.\n"]
320 :     else
321 :     (say ["Building ", target, ".\n"];
322 :     F.chDir treedir;
323 :     if OS.Process.system buildcmd = OS.Process.success then
324 :     if fexists targetheaploc then
325 :     (F.rename { old = targetheaploc,
326 :     new = finalheaploc };
327 :     instcmd target;
328 :     #set (CM.Anchor.anchor target) (SOME bindir))
329 :     else
330 :     fail ["Built ", target, "; ", heapname,
331 :     " still missing.\n"]
332 :     else
333 :     fail ["Building ", target, " failed.\n"];
334 :     write_cm_pathconfig (target, P.concat (P.parentArc, "bin"));
335 :     F.chDir smlnjroot)
336 :     end
337 :    
338 :     (* ------------------------------ *)
339 :    
340 :     (* abbreviations *)
341 :     fun r (a, r, d) = reglib { anchor = a, relname = r, dir = d,
342 :     altanchor = NONE }
343 :     fun r' (a, r, d, aa) = reglib { anchor = a, relname = r, dir = d,
344 :     altanchor = SOME aa }
345 :     fun a (anch, p) = localanchor { anchor = anch, path = p }
346 :    
347 :     fun sa (t, d) =
348 :     standalone { target = t, optheapdir = d, optsrcdir = NONE }
349 :    
350 :     fun sa' (t, d, s) =
351 :     standalone { target = t, optheapdir = d, optsrcdir = SOME s }
352 :    
353 :     (* ------------------------------ *)
354 :    
355 :     (* process one module *)
356 :     fun one "smlnj-lib" =
357 :     (if isUnix then
358 :     r ("unix-lib.cm", "unix-lib.cm", "smlnj-lib/Unix")
359 :     else ();
360 :     r ("inet-lib.cm", "inet-lib.cm", "smlnj-lib/INet");
361 :     r ("regexp-lib.cm", "regexp-lib.cm", "smlnj-lib/RegExp");
362 :     r ("reactive-lib.cm", "reactive-lib.cm", "smlnj-lib/Reactive");
363 :     r ("hash-cons-lib.cm", "hash-cons-lib.cm", "smlnj-lib/HashCons"))
364 :     | one "cml" =
365 :     (r ("cml", "core-cml.cm", "cml/src");
366 :     r ("cml", "cml-internal.cm", "cml/src");
367 :     r ("cml", "cml.cm", "cml/src");
368 :     r ("cml", "basis.cm", "cml/src"))
369 :     | one "cml-lib" =
370 :     (r ("cml-lib", "trace-cml.cm", "cml/cml-lib/cm-descr");
371 :     r ("cml-lib", "smlnj-lib.cm", "cml/cml-lib/cm-descr"))
372 :     | one "eXene" =
373 :     (r ("eXene.cm", "eXene.cm", "eXene"))
374 :     | one "ckit" =
375 :     (r ("ckit-lib.cm", "ckit-lib.cm", "../ckit/src"))
376 :     | one "ml-nlffi-lib" =
377 :     (r ("c", "memory/memory.cm", "ml-nlffi-lib");
378 :     r ("c", "internals/c-int.cm", "ml-nlffi-lib");
379 :     r ("c", "c.cm", "ml-nlffi-lib"))
380 :     | one "pgraph-util" =
381 :     (r ("pgraph-util.cm", "pgraph-util.cm", "cm/pgraph"))
382 :     | one "mlrisc" =
383 : mblume 1409 (a ("Control.cm", P.concat (libdir, "SMLNJ-MLRISC"));
384 :     a ("Lib.cm", P.concat (libdir, "SMLNJ-MLRISC"));
385 :     a ("Visual.cm", P.concat (libdir, "SMLNJ-MLRISC"));
386 :     a ("MLRISC.cm", P.concat (libdir, "SMLNJ-MLRISC"));
387 :     a ("MLTREE.cm", P.concat (libdir, "SMLNJ-MLRISC"));
388 :     a ("Graphs.cm", P.concat (libdir, "SMLNJ-MLRISC"));
389 :     a ("IA32.cm", P.concat (libdir, "SMLNJ-MLRISC"));
390 : mblume 1391 a ("Peephole.cm", "src/MLRISC/cm");
391 :     r' ("OTHER-MLRISC", "RA.cm", "MLRISC/cm", "SMLNJ-MLRISC");
392 :     r' ("OTHER-MLRISC", "Peephole.cm", "MLRISC/cm", "SMLNJ-MLRISC");
393 :     r' ("OTHER-MLRISC", "IA32-Peephole.cm", "MLRISC/cm", "SMLNJ-MLRISC"))
394 :     | one "mlrisc-tools" =
395 :     (r ("mlrisc-tools", "pp.cm", "MLRISC/Tools");
396 :     r ("mlrisc-tools", "source-map.cm", "MLRISC/Tools");
397 :     r ("mlrisc-tools", "sml-ast.cm", "MLRISC/Tools");
398 :     r ("mlrisc-tools", "prec-parser.cm", "MLRISC/Tools");
399 :     r ("mlrisc-tools", "parser.cm", "MLRISC/Tools");
400 :     r ("mlrisc-tools", "match-compiler.cm", "MLRISC/Tools"))
401 :     | one "ml-yacc" =
402 :     sa ("ml-yacc", SOME "src")
403 :     | one "ml-lex" =
404 :     sa ("ml-lex", NONE)
405 :     | one "ml-burg" =
406 :     sa ("ml-burg", NONE)
407 :     | one "ml-nlffigen" =
408 :     salist := (fn () => sa ("ml-nlffigen", NONE))
409 :     :: !salist
410 :     | one "nowhere" =
411 :     salist := (fn () => sa' ("nowhere", NONE, "MLRISC/Tools"))
412 :     :: !salist
413 :     | one module = fail ["unknown module: ", module, "\n"]
414 :     in
415 :     (app one modules;
416 :     if dostabs () andalso domoves () andalso dolatesas () then
417 :     uniqconfig ()
418 :     else fail ["stabilization failed\n"])
419 :     handle e => fail ["unexpected exception: ",
420 :     General.exnMessage e, "\n"];
421 :     OS.Process.exit OS.Process.success
422 :     end
423 :     end

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