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

Parent Directory | 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