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/compiler/TopLevel/batch/cunitutil.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/TopLevel/batch/cunitutil.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 21 - (view) (download)

1 : monnier 21 (* cunitutil.sml
2 :     *
3 :     * Copyright 1989-1995 by AT&T Bell Laboratories.
4 :     *
5 :     * Utility functions for reading and writing of bin files.
6 :     *
7 :     *)
8 :    
9 :     signature CUNITUTIL =
10 :     sig
11 :    
12 :     exception FormatError
13 :     exception NoCodeBug
14 :    
15 :     type 'iid cunit
16 :     type pid = PersStamps.persstamp
17 :    
18 :     type senv = SCEnv.Env.staticEnv
19 :     type symenv = SCEnv.Env.symenv
20 :     type env = SCEnv.Env.environment
21 :     type lambda = Lambda.lexp
22 :    
23 :     type csegments = {c0: Word8Vector.vector, cn: Word8Vector.vector list, name: string option ref}
24 :    
25 :     type obj = Unsafe.Object.object
26 :    
27 :     val readUnit: { name: string,
28 :     stream: BinIO.instream,
29 :     pids2iid: pid list -> 'iid,
30 :     senv: senv,
31 :     keep_code: bool }
32 :     -> 'iid cunit
33 :    
34 :     val writeUnit: { stream: BinIO.outstream,
35 :     cunit: 'iid cunit,
36 :     keep_code: bool,
37 :     iid2pids: 'iid -> pid list }
38 :     -> unit
39 :    
40 :     (* the hashing/pickling of environments is already done by the
41 :     * elaborator; lambda's must be hashed/pickled here *)
42 :     val makeUnit: { imports: pid list,
43 :     exportPid: pid option,
44 :     references: 'iid,
45 :    
46 :     staticPid: pid,
47 :     newenv: senv,
48 :     newenvPickle: Word8Vector.vector,
49 :    
50 :     lambda_i: lambda option,
51 :    
52 :     code: csegments } -> 'iid cunit
53 :    
54 :     val staticPidCU: 'iid cunit -> pid
55 :     val lambdaPidCU: 'iid cunit -> pid
56 :     val senvCU: 'iid cunit -> senv
57 :     val symenvCU: 'iid cunit -> symenv
58 :     val envCU: 'iid cunit -> env option ref
59 :     val importsCU: 'iid cunit -> pid list
60 :     val exportCU: 'iid cunit -> pid option
61 :     val referencesCU: 'iid cunit -> 'iid
62 :    
63 :     val nocodeCU: 'iid cunit -> bool
64 :    
65 :     val codeClosure: 'iid cunit -> obj vector -> obj
66 :     val discardCode: 'iid cunit -> unit
67 :     end
68 :    
69 :     functor CUnitUtilFun(
70 :     structure Compile : COMPILE
71 :     structure Machm: CODEGENERATOR
72 :     ) : CUNITUTIL = struct
73 :    
74 :     structure Pid = PersStamps
75 :     structure Env = SCEnv.Env
76 :     structure Comp = Compile
77 :     structure Err = ErrorMsg
78 :    
79 :     exception FormatError
80 :     exception NoCodeBug
81 :    
82 :     fun error msg = (
83 :     Control.Print.say(concat["Bin file format error: ", msg, "\n"]);
84 :     raise FormatError)
85 :    
86 :     type pid = Pid.persstamp
87 :     type senv = Env.staticEnv
88 :     type symenv = Env.symenv
89 :     type env = Env.environment
90 :     type lambda = Lambda.lexp
91 :    
92 :     type obj = Unsafe.Object.object
93 :     type objvec = obj Vector.vector
94 :    
95 :     type csegments = Comp.csegments
96 :    
97 :     datatype code
98 :     = DISCARDED
99 :     | CSEGS of csegments
100 :     | CLOSURE of objvec -> obj
101 :    
102 :     datatype 'iid cunit = CU of {
103 :     imports: pid list,
104 :     exportPid: pid option,
105 :     references: 'iid,
106 :     staticPid: pid,
107 :     senv: senv,
108 :     penv: Word8Vector.vector,
109 :     lambdaPid: pid,
110 :     lambda: lambda option,
111 :     plambda: Word8Vector.vector,
112 :     env: env option ref,
113 :     code: code ref
114 :     }
115 :    
116 :     fun importsCU (CU{ imports, ...}) = imports
117 :     fun exportCU (CU{exportPid, ...}) = exportPid
118 :     fun referencesCU (CU{references, ...}) = references
119 :     fun staticPidCU (CU{ staticPid, ... }) = staticPid
120 :     fun lambdaPidCU (CU{ lambdaPid, ... }) = lambdaPid
121 :     fun senvCU (CU{senv, ... }) = senv
122 :     fun symenvCU (CU{exportPid, lambda, ... }) =
123 :     Comp.symDelta (exportPid, lambda)
124 :     fun penvCU (CU{penv = pe, ... }) = pe
125 :     fun envCU (CU{env = e, ... }) = e
126 :    
127 :     fun nocodeCU (CU{ code = ref DISCARDED, ... }) = true
128 :     | nocodeCU _ = false
129 :    
130 :     fun codeSegments (CU{code = ref (CSEGS s), ... }) = s
131 :     | codeSegments _ = raise NoCodeBug
132 :    
133 :     fun codeClosure (CU{code, ... }) = (case !code
134 :     of DISCARDED => raise NoCodeBug
135 :     | CLOSURE obj => obj
136 :     | CSEGS s => let
137 :     val obj = Comp.applyCode s
138 :     in
139 :     code := CLOSURE obj; obj
140 :     end
141 :     (* end case *))
142 :    
143 :     fun discardCode (CU{code, ... }) = code := DISCARDED
144 :    
145 :     val fromInt = Word32.fromInt
146 :     val fromByte = Word32.fromLargeWord o Word8.toLargeWord
147 :     val toByte = Word8.fromLargeWord o Word32.toLargeWord
148 :     val >> = Word32.>>
149 :     infix >>
150 :    
151 :     (*
152 :     * layout of binfiles:
153 :     * - 0..x-1: magic string (length = x)
154 :     * - x..x+3: # of imports (= y)
155 :     * - x+4..x+7: # of exports (= z)
156 :     * - x+8..x+11: size CM-info = (# of envPids) * bytesPerPid
157 :     * - x+12..x+15: size lambda_i
158 :     * - x+16..x+19: size reserved area1
159 :     * - x+20..x+23: size reserved area2
160 :     * - x+24..x+27: size code
161 :     * - x+28..x+31: size env
162 :     * - x+32..x+y+31: import pids
163 :     * - x+y+32..x+y+z+31: export pids
164 :     * - ... CM-specific info (env pids)
165 :     * - lambda_i
166 :     * - reserved area1
167 :     * - reserved area2
168 :     * - code
169 :     * - pickled_env
170 :     * EOF
171 :     *
172 :     * All counts and sizes are represented in big-endian layout.
173 :     * This should be tracked by the run-time system header file
174 :     * "runtime/include/bin-file.h"
175 :     *)
176 :    
177 :     val MAGIC = let
178 :     fun fit (i, s) = let
179 :     val s = StringCvt.padRight #" " i s
180 :     in
181 :     if (size s = i) then s
182 :     else substring (s, 0, i)
183 :     end
184 :     fun version [] = []
185 :     | version [x : int] = [Int.toString x]
186 :     | version (x :: r) = (Int.toString x) :: "." :: (version r)
187 :     val v = fit (8, concat (version (#version_id Version.version)))
188 :     val a = Machm.architecture
189 :     val a = if String.sub (a, 0) = #"."
190 :     then fit (7, substring (a, 1, (String.size a) - 1))
191 :     else fit (7, a)
192 :     in
193 :     Byte.stringToBytes (concat [v, a, "\n"])
194 :     end
195 :    
196 :     val magicBytes = Word8Vector.length MAGIC
197 :     val bytesPerPid = 16
198 :    
199 :     fun bytesIn (s, n) = let
200 :     val bv = BinIO.inputN (s, n)
201 :     in
202 :     if (n = Word8Vector.length bv)
203 :     then bv
204 :     else error(concat[
205 :     "expected ", Int.toString n, " byte, but found ",
206 :     Int.toString(Word8Vector.length bv)
207 :     ])
208 :     end
209 :    
210 :     fun readInt32 s = LargeWord.toIntX(Pack32Big.subVec(bytesIn(s, 4), 0))
211 :    
212 :     fun readPid s = Pid.fromBytes (bytesIn (s, bytesPerPid))
213 :     fun readPidList (s, n) = List.tabulate (n, fn _ => readPid s)
214 :    
215 :     fun writeInt32 s i = let
216 :     val w = fromInt i
217 :     fun out w = BinIO.output1 (s, toByte w)
218 :     in
219 :     out (w >> 0w24); out (w >> 0w16); out (w >> 0w8); out w
220 :     end
221 :    
222 :     fun writePid (s, pid) = BinIO.output (s, Pid.toBytes pid)
223 :     fun writePidList (s, l) = app (fn p => writePid (s, p)) l
224 :    
225 :     fun checkMagic s =
226 :     if (bytesIn (s, magicBytes)) = MAGIC then () else error "bad magic number"
227 :    
228 :     fun readHeader s = let
229 :     val _ = checkMagic s
230 :     val ni = readInt32 s
231 :     val ne = readInt32 s
232 :     val cmInfoSzB = readInt32 s
233 :     val nei = cmInfoSzB div bytesPerPid
234 :     val sLam = readInt32 s
235 :     val sa1 = readInt32 s
236 :     val sa2 = readInt32 s
237 :     val cs = readInt32 s
238 :     val es = readInt32 s
239 :     val imports = readPidList (s, ni)
240 :     val exportPid = (case ne
241 :     of 0 => NONE
242 :     | 1 => SOME(readPid s)
243 :     | _ => error "too many export PIDs"
244 :     (* end case *))
245 :     val envPids = readPidList (s, nei)
246 :     in
247 :     case envPids
248 :     of (st :: lm :: references) => {
249 :     nImports = ni, nExports = ne,
250 :     lambdaSz = sLam,
251 :     res1Sz = sa1, res2Sz = sa2, codeSz = cs, envSz = es,
252 :     imports = imports, exportPid = exportPid,
253 :     references = references, staticPid = st, lambdaPid = lm
254 :     }
255 :     | _ => error "env PID list"
256 :     (* end case *)
257 :     end
258 :    
259 :     (* must be called with second arg >= 0 *)
260 :     fun readCodeList (_, 0) = []
261 :     | readCodeList (s, n) = let
262 :     val sz = readInt32 s
263 :     val n' = n - sz - 4
264 :     val c = if n' < 0 then error "code size" else bytesIn (s, sz)
265 :     in
266 :     c :: readCodeList (s, n')
267 :     end
268 :    
269 :     fun readUnit {name=n, stream = s, pids2iid, senv = context, keep_code} = let
270 :     val { nImports = ni, nExports = ne, lambdaSz = sa2,
271 :     res1Sz, res2Sz, codeSz = cs, envSz = es,
272 :     imports, exportPid, references,
273 :     staticPid, lambdaPid
274 :     } = readHeader s
275 :     val iid = pids2iid references
276 :     val (plambda, lambda_i) = if sa2 = 0
277 :     then (Word8Vector.fromList [], NONE)
278 :     else let
279 :     val bytes = bytesIn (s, sa2)
280 :     in
281 :     (bytes, UnpickMod.unpickleLambda{hash=staticPid,pickle=bytes})
282 :     end
283 :     val _ = if res1Sz = 0 andalso res2Sz = 0
284 :     then () else error "non-zero reserved size"
285 :     val code = (case readCodeList (s, cs)
286 :     of [] => error "missing code objects"
287 :     | c0 :: cn => { c0 = c0, cn = cn, name=ref(SOME(n)) }
288 :     (* end case *))
289 :     val penv = bytesIn (s, es)
290 :     val _ = if Word8Vector.length penv = es andalso BinIO.endOfStream s
291 :     then ()
292 :     else error "missing/excess bytes in bin file"
293 :     val b'senv = UnpickMod.unpickleEnv (context, { hash = staticPid,
294 :     pickle = penv })
295 :     val senv = SCStaticEnv.SC b'senv
296 :     in
297 :     CU {
298 :     imports = imports, exportPid = exportPid, references = iid,
299 :     staticPid = staticPid, senv = senv, penv = penv,
300 :     lambdaPid = lambdaPid, lambda = lambda_i, plambda = plambda,
301 :     env = ref NONE,
302 :     code = ref (if keep_code then CSEGS code else DISCARDED)
303 :     }
304 :     end
305 :    
306 :     fun writeUnit {stream = s, cunit = u, keep_code, iid2pids} = let
307 :     val CU{
308 :     imports, exportPid, references,
309 :     staticPid, penv,
310 :     lambdaPid, lambda, plambda, ...
311 :     } = u
312 :     val envPids = staticPid :: lambdaPid :: iid2pids references
313 :     val ni = length imports
314 :     val (ne, epl) = (case exportPid of NONE => (0, []) | SOME p => (1, [p]))
315 :     val nei = length envPids
316 :     val cmInfoSzB = nei * bytesPerPid
317 :     val sa2 = (case lambda of NONE => 0 | _ => Word8Vector.length plambda)
318 :     val res1Sz = 0
319 :     val res2Sz = 0
320 :     val { c0, cn , ...} = codeSegments u
321 :     fun csize c = (Word8Vector.length c) + 4 (* including size field *)
322 :     val cs = foldl (fn (c, a) => (csize c) + a) (csize c0) cn
323 :     fun codeOut c = (
324 :     writeInt32 s (Word8Vector.length c);
325 :     BinIO.output (s, c))
326 :     in
327 :     BinIO.output (s, MAGIC);
328 :     app (writeInt32 s) [ni, ne, cmInfoSzB];
329 :     app (writeInt32 s) [sa2, res1Sz, res2Sz, cs];
330 :     writeInt32 s (Word8Vector.length penv);
331 :     writePidList (s, imports);
332 :     writePidList (s, epl);
333 :     (* arena1 *)
334 :     writePidList (s, envPids);
335 :     (* arena2 *)
336 :     case lambda of NONE => () | _ => BinIO.output (s, plambda);
337 :     (* arena3 is empty *)
338 :     (* arena4 is empty *)
339 :     (* code objects *)
340 :     codeOut c0;
341 :     app codeOut cn;
342 :     BinIO.output (s, penv);
343 :     if keep_code then () else discardCode u
344 :     end
345 :    
346 :     fun makeUnit {
347 :     imports, exportPid, references,
348 :     staticPid, newenv, newenvPickle,
349 :     code, lambda_i
350 :     } = let
351 :     val {hash = lambdaPid, pickle} = PickMod.pickleLambda lambda_i
352 :     in
353 :     CU{
354 :     imports = imports,
355 :     exportPid = exportPid,
356 :     references = references,
357 :     staticPid = staticPid,
358 :     senv = newenv,
359 :     penv = newenvPickle,
360 :     lambdaPid = lambdaPid,
361 :     lambda = lambda_i,
362 :     plambda = pickle,
363 :     env = ref NONE,
364 :     code = ref (CSEGS code)
365 :     }
366 :     end
367 :    
368 :     end
369 :    
370 :     (*
371 :     * $Log: cunitutil.sml,v $
372 :     * Revision 1.6 1997/08/25 19:20:03 riccardo
373 :     * Added support for tagging code objects with their source/bin file name.
374 :     *
375 :     * Revision 1.5 1997/08/11 18:29:39 george
376 :     * Simplified the modmap handling by no longer paying attention to
377 :     * space leak problems. Such problems don't matter in this version,
378 :     * because modmaps aren't used for the top-level environment.
379 :     * -- blume
380 :     *
381 :     * Revision 1.4 1997/07/28 23:04:10 dbm
382 :     * Fix from Matthias for CM slowdown due to environment building.
383 :     *
384 :     * Revision 1.3 1997/06/30 19:37:03 jhr
385 :     * Removed System structure; added Unsafe structure.
386 :     *
387 :     * Revision 1.2 1997/02/11 15:16:20 george
388 :     * moved stuff from System to SMLofNJ
389 :     *
390 :     * Revision 1.1.1.1 1997/01/14 01:38:27 george
391 :     * Version 109.24
392 :     *
393 :     *)

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