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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/TopLevel/batch/batchutil.sml

1 : monnier 16 (* COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies *)
2 :     (* batchutil.sml *)
3 :    
4 :     functor BatchUtilFun(C : COMPILE) : BATCHUTIL =
5 :     struct
6 :     structure Pid = PersStamps
7 :     structure Env = SCEnv.Env
8 :     structure Err = ErrorMsg
9 :    
10 :     exception FormatError
11 :     exception NoCodeBug
12 :    
13 :     fun error msg = (
14 :     Control.Print.say(concat["Bin file format error: ", msg, "\n"]);
15 :     raise FormatError)
16 :    
17 :     (***************************************************************************
18 :     * UTILITY FUNCTIONS FOR MANIPULATING CUNIT *
19 :     ***************************************************************************)
20 :    
21 :     type pid = Pid.persstamp
22 :     type senv = Env.staticEnv
23 :     type symenv = Env.symenv
24 :     type denv = Env.dynenv
25 :     type env = Env.environment
26 :     type lambda = CompBasic.flint
27 :    
28 :     type csegments = C.csegments
29 :     type executable = C.executable
30 :    
31 :     datatype code
32 :     = DISCARDED
33 :     | CSEGS of csegments
34 :     | CLOSURE of executable
35 :    
36 :     datatype 'iid cunit = CU of {
37 :     imports: pid list,
38 :     exportPid: pid option,
39 :     references: 'iid,
40 :     staticPid: pid,
41 :     senv: senv,
42 :     penv: Word8Vector.vector,
43 :     lambdaPid: pid,
44 :     lambda: lambda option,
45 :     plambda: Word8Vector.vector,
46 :     env: env option ref,
47 :     code: code ref
48 :     }
49 :    
50 :     val arch = C.architecture
51 :     fun importsCU (CU{ imports, ...}) = imports
52 :     fun exportCU (CU{exportPid, ...}) = exportPid
53 :     fun referencesCU (CU{references, ...}) = references
54 :     fun staticPidCU (CU{ staticPid, ... }) = staticPid
55 :     fun lambdaPidCU (CU{ lambdaPid, ... }) = lambdaPid
56 :     fun senvCU (CU{senv, ... }) = senv
57 :     fun symenvCU (CU{exportPid, lambda, ... }) = C.mksymenv (exportPid, lambda)
58 :     fun penvCU (CU{penv = pe, ... }) = pe
59 :     fun envCU (CU{env = e, ... }) = e
60 :    
61 :     fun nocodeCU (CU{ code = ref DISCARDED, ... }) = true
62 :     | nocodeCU _ = false
63 :    
64 :     fun codeSegments (CU{code = ref (CSEGS s), ... }) = s
65 :     | codeSegments _ = raise NoCodeBug
66 :    
67 :     fun discardCode (CU{code, ... }) = code := DISCARDED
68 :    
69 :     val fromInt = Word32.fromInt
70 :     val fromByte = Word32.fromLargeWord o Word8.toLargeWord
71 :     val toByte = Word8.fromLargeWord o Word32.toLargeWord
72 :     val >> = Word32.>>
73 :     infix >>
74 :    
75 :     (*
76 :     * layout of binfiles:
77 :     * - 0..x-1: magic string (length = x)
78 :     * - x..x+3: # of imports (= y)
79 :     * - x+4..x+7: # of exports (= z)
80 :     * - x+8..x+11: size CM-info = (# of envPids) * bytesPerPid
81 :     * - x+12..x+15: size lambda_i
82 :     * - x+16..x+19: size reserved area1
83 :     * - x+20..x+23: size reserved area2
84 :     * - x+24..x+27: size code
85 :     * - x+28..x+31: size env
86 :     * - x+32..x+y+31: import pids
87 :     * - x+y+32..x+y+z+31: export pids
88 :     * - ... CM-specific info (env pids)
89 :     * - lambda_i
90 :     * - reserved area1
91 :     * - reserved area2
92 :     * - code
93 :     * - pickled_env
94 :     * EOF
95 :     *
96 :     * All counts and sizes are represented in big-endian layout.
97 :     * This should be tracked by the run-time system header file
98 :     * "runtime/include/bin-file.h"
99 :     *)
100 :    
101 :     val MAGIC = let
102 :     fun fit (i, s) = let
103 :     val s = StringCvt.padRight #" " i s
104 :     in
105 :     if (size s = i) then s
106 :     else substring (s, 0, i)
107 :     end
108 :     fun version [] = []
109 :     | version [x : int] = [Int.toString x]
110 :     | version (x :: r) = (Int.toString x) :: "." :: (version r)
111 :     val v = fit (8, concat (version (#version_id Version.version)))
112 :     val a = if String.sub (arch, 0) = #"."
113 :     then fit (7, substring (arch, 1, (String.size arch) - 1))
114 :     else fit (7, arch)
115 :     in
116 :     Byte.stringToBytes (concat [v, a, "\n"])
117 :     end
118 :    
119 :     val magicBytes = Word8Vector.length MAGIC
120 :     val bytesPerPid = 16
121 :    
122 :     fun bytesIn (s, n) = let
123 :     val bv = BinIO.inputN (s, n)
124 :     in
125 :     if (n = Word8Vector.length bv)
126 :     then bv
127 :     else error(concat[
128 :     "expected ", Int.toString n, " byte, but found ",
129 :     Int.toString(Word8Vector.length bv)
130 :     ])
131 :     end
132 :    
133 :     fun readInt32 s = LargeWord.toIntX(Pack32Big.subVec(bytesIn(s, 4), 0))
134 :    
135 :     fun readPid s = Pid.fromBytes (bytesIn (s, bytesPerPid))
136 :     fun readPidList (s, n) = List.tabulate (n, fn _ => readPid s)
137 :    
138 :     fun writeInt32 s i = let
139 :     val w = fromInt i
140 :     fun out w = BinIO.output1 (s, toByte w)
141 :     in
142 :     out (w >> 0w24); out (w >> 0w16); out (w >> 0w8); out w
143 :     end
144 :    
145 :     fun writePid (s, pid) = BinIO.output (s, Pid.toBytes pid)
146 :     fun writePidList (s, l) = app (fn p => writePid (s, p)) l
147 :    
148 :     fun checkMagic s =
149 :     if (bytesIn (s, magicBytes)) = MAGIC then () else error "bad magic number"
150 :    
151 :     fun readHeader s = let
152 :     val _ = checkMagic s
153 :     val ni = readInt32 s
154 :     val ne = readInt32 s
155 :     val cmInfoSzB = readInt32 s
156 :     val nei = cmInfoSzB div bytesPerPid
157 :     val sLam = readInt32 s
158 :     val sa1 = readInt32 s
159 :     val sa2 = readInt32 s
160 :     val cs = readInt32 s
161 :     val es = readInt32 s
162 :     val imports = readPidList (s, ni)
163 :     val exportPid = (case ne
164 :     of 0 => NONE
165 :     | 1 => SOME(readPid s)
166 :     | _ => error "too many export PIDs"
167 :     (* end case *))
168 :     val envPids = readPidList (s, nei)
169 :     in
170 :     case envPids
171 :     of (st :: lm :: references) => {
172 :     nImports = ni, nExports = ne,
173 :     lambdaSz = sLam,
174 :     res1Sz = sa1, res2Sz = sa2, codeSz = cs, envSz = es,
175 :     imports = imports, exportPid = exportPid,
176 :     references = references, staticPid = st, lambdaPid = lm
177 :     }
178 :     | _ => error "env PID list"
179 :     (* end case *)
180 :     end
181 :    
182 :     (* must be called with second arg >= 0 *)
183 :     fun readCodeList (_, 0) = []
184 :     | readCodeList (s, n) = let
185 :     val sz = readInt32 s
186 :     val n' = n - sz - 4
187 :     val c = if n' < 0 then error "code size" else bytesIn (s, sz)
188 :     in
189 :     c :: readCodeList (s, n')
190 :     end
191 :    
192 :     fun readUnit {name=n, stream = s, pids2iid, senv = context, keep_code} = let
193 :     val { nImports = ni, nExports = ne, lambdaSz = sa2,
194 :     res1Sz, res2Sz, codeSz = cs, envSz = es,
195 :     imports, exportPid, references,
196 :     staticPid, lambdaPid
197 :     } = readHeader s
198 :     val iid = pids2iid references
199 :     val (plambda, lambda_i) = if sa2 = 0
200 :     then (Word8Vector.fromList [], NONE)
201 :     else let
202 :     val bytes = bytesIn (s, sa2)
203 :     in
204 :     (bytes,
205 :     UnpickMod.unpickleFLINT{hash=staticPid,pickle=bytes})
206 :     end
207 :     val _ = if res1Sz = 0 andalso res2Sz = 0
208 :     then () else error "non-zero reserved size"
209 :     val code = (case readCodeList (s, cs)
210 :     of [] => error "missing code objects"
211 :     | c0 :: cn => { c0 = c0, cn = cn, name=ref(SOME(n)) }
212 :     (* end case *))
213 :     val penv = bytesIn (s, es)
214 :     val _ = if Word8Vector.length penv = es andalso BinIO.endOfStream s
215 :     then ()
216 :     else error "missing/excess bytes in bin file"
217 :     val b'senv = UnpickMod.unpickleEnv (context, { hash = staticPid,
218 :     pickle = penv })
219 :     val senv = SCStaticEnv.SC b'senv
220 :     in
221 :     CU {
222 :     imports = imports, exportPid = exportPid, references = iid,
223 :     staticPid = staticPid, senv = senv, penv = penv,
224 :     lambdaPid = lambdaPid, lambda = lambda_i, plambda = plambda,
225 :     env = ref NONE,
226 :     code = ref (if keep_code then CSEGS code else DISCARDED)
227 :     }
228 :     end
229 :    
230 :     fun writeUnit {stream = s, cunit = u, keep_code, iid2pids} = let
231 :     val CU{
232 :     imports, exportPid, references,
233 :     staticPid, penv,
234 :     lambdaPid, lambda, plambda, ...
235 :     } = u
236 :     val envPids = staticPid :: lambdaPid :: iid2pids references
237 :     val ni = length imports
238 :     val (ne, epl) = (case exportPid of NONE => (0, [])
239 :     | SOME p => (1, [p]))
240 :     val nei = length envPids
241 :     val cmInfoSzB = nei * bytesPerPid
242 :     val sa2 = (case lambda of NONE => 0
243 :     | _ => Word8Vector.length plambda)
244 :     val res1Sz = 0
245 :     val res2Sz = 0
246 :     val { c0, cn , ...} = codeSegments u
247 :     fun csize c = (Word8Vector.length c) + 4 (* including size field *)
248 :     val cs = foldl (fn (c, a) => (csize c) + a) (csize c0) cn
249 :     fun codeOut c = (
250 :     writeInt32 s (Word8Vector.length c);
251 :     BinIO.output (s, c))
252 :     in
253 :     BinIO.output (s, MAGIC);
254 :     app (writeInt32 s) [ni, ne, cmInfoSzB];
255 :     app (writeInt32 s) [sa2, res1Sz, res2Sz, cs];
256 :     writeInt32 s (Word8Vector.length penv);
257 :     writePidList (s, imports);
258 :     writePidList (s, epl);
259 :     (* arena1 *)
260 :     writePidList (s, envPids);
261 :     (* arena2 *)
262 :     case lambda of NONE => () | _ => BinIO.output (s, plambda);
263 :     (* arena3 is empty *)
264 :     (* arena4 is empty *)
265 :     (* code objects *)
266 :     codeOut c0;
267 :     app codeOut cn;
268 :     BinIO.output (s, penv);
269 :     if keep_code then () else discardCode u
270 :     end
271 :    
272 :    
273 :     (***************************************************************************
274 :     * UTILITY FUNCTIONS THAT SUPPORTS BATCH COMPILATION *
275 :     ***************************************************************************)
276 :     exception Compile = C.Compile
277 :     exception TopLevelException = C.TopLevelException
278 :     exception SilentException = C.SilentException
279 :    
280 :     val parse = C.parse
281 :     val makePid = C.makePid
282 :    
283 :     fun makeUnit {runtimePid : pid option, splitting, references,
284 :     ast, source, corenv, senv : senv, symenv : symenv} = let
285 :     val errors = Err.errors source
286 :     fun check phase =
287 :     if Err.anyErrors errors then raise Compile (phase ^ " failed")
288 :     else ()
289 :     val cinfo = C.mkCompInfo (source, corenv, fn x => x)
290 :    
291 :     val {csegments=code, newstatenv, exportPid, staticPid, imports,
292 :     pickle=envPickle, inlineExp, ...} =
293 :     C.compile {source=source, ast=ast, statenv=senv,
294 :     symenv=symenv, compInfo=cinfo, checkErr=check,
295 :     runtimePid=runtimePid, splitting=splitting}
296 :     val {hash = lambdaPid, pickle} = PickMod.pickleFLINT inlineExp
297 :     in
298 :     CU{
299 :     imports = imports,
300 :     exportPid = exportPid,
301 :     references = references,
302 :     staticPid = staticPid,
303 :     senv = newstatenv,
304 :     penv = envPickle,
305 :     lambdaPid = lambdaPid,
306 :     lambda = inlineExp,
307 :     plambda = pickle,
308 :     env = ref NONE,
309 :     code = ref (CSEGS code)
310 :     }
311 :     end (* function makeUnit *)
312 :    
313 :     fun codeClosure (CU{code, ... }) = (case !code
314 :     of DISCARDED => raise NoCodeBug
315 :     | CLOSURE obj => obj
316 :     | CSEGS s => let
317 :     val obj = C.mkexec s
318 :     in
319 :     code := CLOSURE obj; obj
320 :     end
321 :     (* end case *))
322 :    
323 :     fun execUnit (u, denv) = let
324 :     val ndenv =
325 :     C.execute { executable = codeClosure u,
326 :     imports = importsCU u,
327 :     exportPid = exportCU u,
328 :     dynenv = denv }
329 :     in
330 :     Env.mkenv {static = senvCU u,
331 :     dynamic = ndenv,
332 :     symbolic = symenvCU u}
333 :     end
334 :    
335 :     end (* functor BatchUtilFun *)

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