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/config/libinstall.sml
ViewVC logotype

Annotation of /sml/trunk/config/libinstall.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1385 - (view) (download)

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

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