1(****************************************************************************
2*Copyright 2008
3*  Andrew Gacek, Steven Holte, Gopalan Nadathur, Xiaochu Qi, Zach Snow
4****************************************************************************)
5(****************************************************************************
6* This file is part of Teyjus.
7*
8* Teyjus is free software: you can redistribute it and/or modify
9* it under the terms of the GNU General Public License as published by
10* the Free Software Foundation, either version 3 of the License, or
11* (at your option) any later version.
12*
13* Teyjus is distributed in the hope that it will be useful,
14* but WITHOUT ANY WARRANTY; without even the implied warranty of
15* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16* GNU General Public License for more details.
17*
18* You should have received a copy of the GNU General Public License
19* along with Teyjus.  If not, see <http://www.gnu.org/licenses/>.
20****************************************************************************)
21(**************************************************************************)
22(* This module provides auxiliary functions and flags for writing and     *)
23(* reading bytecode files.                                                *)
24(**************************************************************************)
25
26(** ******************************************************************** **)
27(**                       BYTECODE FORMAT                                **)
28(** ******************************************************************** **)
29let byteCodeVersionNumber = 2
30let byteCodeSuffix = ".lpo"
31
32let linkedByteCodeVersionNumber = 3
33let linkedByteCodeSuffix = ".lp"
34
35let makeByteCodeFileName modName   = modName ^ byteCodeSuffix
36let makeLinkedByteCodeName modName = modName ^ linkedByteCodeSuffix
37
38(* type skeleton representation *)
39let typeMarkArrow       = 0
40let typeMarkKind        = 1
41let typeMarkSkeletonVar = 2
42
43(* constant fixity *)
44let fixityMarkInfix = 0
45let fixityMarkInfixl = 1
46let fixityMarkInfixr = 2
47let fixityMarkNoFixity = 3
48let fixityMarkPrefix = 4
49let fixityMarkPrefixr = 5
50let fixityMarkPostfix = 6
51let fixityMarkPostfixl =7
52
53(* constant/kind category *)
54let global = 0
55let local  = 1
56let hidden = 2
57let pervasive = 3
58
59(* find code function: hash or sequence search *)
60let findCodeFuncMarkHash = 1
61let findCodeFuncMarkSeq  = 0
62
63(** ******************************************************************** **)
64(**                       IO FACILITIES                                  **)
65(** ******************************************************************** **)
66
67(**********************************************************************)
68(* record the number of bytes contained by a word (needed for reading *)
69(* or writing a word).                                                *)
70(**********************************************************************)
71let wordSize = ref 0
72
73let setWordSize () =
74  let rec setWordSizeAux number wordSize =
75	if (number = 0) then wordSize
76	else setWordSizeAux (number lsr 8) (wordSize + 1)
77  in
78  wordSize := setWordSizeAux max_int 0
79
80let getWordSize () = !wordSize
81
82(******************************************************************)
83(* management of output channel                                   *)
84(******************************************************************)
85let outChannel : out_channel ref = ref stderr
86let getOutChannel ()      = !outChannel
87let setOutChannel output  = outChannel := output
88
89let openOutChannel name =
90  try
91    let outFile = open_out_bin name in
92    setOutChannel outFile
93  with
94    Sys_error(s) -> (prerr_endline ("Error: " ^ s); exit (-1))
95
96let closeOutChannel () =
97  close_out (getOutChannel ());
98  setOutChannel stderr
99
100(******************************************************************)
101(* management of input channel                                    *)
102(******************************************************************)
103let inChannel : in_channel ref = ref stdin
104let getInChannel ()     = !inChannel
105let setInChannel input  = inChannel := input
106
107let openInChannel name =
108  try
109    let inFile = open_in_bin name in
110    setInChannel inFile
111  with
112    Sys_error(s) -> (prerr_endline ("Error: " ^ s); exit (-1))
113
114let closeInChannel () =
115  close_in (getInChannel ());
116  setInChannel stdin
117
118(** ******************************************************************* **)
119(**                      WRITE FUNCTIONS                                **)
120(** ******************************************************************* **)
121
122(*******************************************************************)
123(* functions for writing certain numbers of bytes to output channel*)
124(*******************************************************************)
125(* aux: writing n bytes to the given channel *)
126let rec writeNBytes out number numBytes =
127  let byte = number land 0xff in
128  (if numBytes > 1 then writeNBytes out (number lsr 8) (numBytes - 1)
129   else ());
130  output_byte out byte
131
132let rec writeNBytes2 out number numBytes =
133  let byte = Int32.to_int (Int32.logand number (Int32.of_int 0xff)) in
134   (if numBytes > 1 then
135     writeNBytes2 out (Int32.shift_right_logical number 8) (numBytes - 1)
136   else ());
137   output_byte out byte
138
139
140
141(* one byte     *)
142let writeint1 number = writeNBytes (getOutChannel ()) number 1
143
144(* two bytes    *)
145let writeint2 number = writeNBytes (getOutChannel ()) number 2
146
147(* four bytes   *)
148let writeint4 number = writeNBytes (getOutChannel ()) number 4
149
150(* four bytes reference  *)
151let writeintref4 numberRef = writeNBytes (getOutChannel ()) (!numberRef) 4
152
153(* eight bytes  *)
154let writeint8 number = writeNBytes (getOutChannel ()) number 8
155
156(* eight bytes reference *)
157let writeintref8 numberRef = writeNBytes (getOutChannel ()) (!numberRef) 8
158
159(* write a word:                                       *)
160(* the number of bytes depend on machine architecture  *)
161let writeWord number =
162  writeNBytes (getOutChannel ()) number (getWordSize ())
163
164(* write a float number:                               *)
165(* 8 bytes with the first four being the mantissa and  *)
166(* the folloing being the exponent.                    *)
167let writefloat4 number =
168  let (significant, exponent) = frexp number in
169  let mantissa = Int32.of_float (ldexp significant 31) in
170  let myOutChannel = getOutChannel () in
171  writeNBytes2 myOutChannel mantissa 4;
172  writeNBytes myOutChannel exponent 4
173
174(* write a string:                                     *)
175(* the leading byte contains the length of the string  *)
176(* and is followed by a sequence of characters.        *)
177let writeString str =
178  writeint4 (String.length str);
179  output_string (getOutChannel ()) str
180
181let writeLongString str =
182  writeint4 (String.length str);
183  output_string (getOutChannel ()) str
184
185(* write a kind index:                                 *)
186(* a one byte flag indicating the kind category        *)
187(* followed by two bytes kind table index.             *)
188let writeakind2 kind =
189  (match (Absyn.getKindType kind) with
190	Absyn.LocalKind -> writeint1 local
191  | Absyn.GlobalKind -> writeint1 global
192  | Absyn.PervasiveKind -> writeint1 pervasive);
193  writeint2 (Absyn.getKindIndex kind)
194
195(* write a constant index:                             *)
196(* a one byte flag indicating the constant category    *)
197(* followed by two bytes constant table index.         *)
198let writeaconstant2 const =
199  let constCat = Absyn.getConstantType const in
200  let constIndex = Absyn.getConstantIndex const in
201  (match constCat with
202	Absyn.GlobalConstant -> writeint1 global
203  | Absyn.LocalConstant  -> writeint1 local
204  | Absyn.PervasiveConstant(_) -> writeint1 pervasive
205  | _ (* must be hidden constants*) -> writeint1 hidden);
206  writeint2 constIndex
207
208(** ******************************************************************* **)
209(**                       READ FUNCTIONS                                **)
210(** ******************************************************************* **)
211
212(********************************************************************)
213(* functions for reading certain numbers of bytes from input channel*)
214(********************************************************************)
215(* aux: read N bytes as an integer:                     *)
216(* it is assumed that the number of bytes is less then  *)
217(* that of an integer type.                             *)
218let readNBytes input numBytes =
219  let rec readNBytesAux numBytes number =
220	if (numBytes = 0) then number
221	else
222	  let oneByte = input_byte input  in
223	  readNBytesAux (numBytes - 1) ((number lsl 8) lor oneByte)
224  in
225  readNBytesAux numBytes 0
226
227let readNBytes2 input numBytes =
228  let rec readNBytesAux numBytes number =
229    if (numBytes = 0) then number
230    else
231      let oneByte = input_byte input in
232      readNBytesAux (numBytes - 1)
233	(Int32.logor (Int32.shift_left number 8) (Int32.of_int oneByte))
234  in
235  readNBytesAux numBytes (Int32.of_int 0)
236
237
238(* read one byte  *)
239let readOneByte  () = readNBytes (getInChannel ()) 1
240
241(* read two bytes *)
242let readTwoBytes () = readNBytes (getInChannel ()) 2
243
244(* read a word    *)
245let readWord () = readNBytes (getInChannel ()) (getWordSize ())
246
247(* read a string  *)
248let readString () =
249  let input = getInChannel () in
250  let length = readNBytes input 4 in
251  let myString = Bytes.make length ' ' in
252  let rec readStringAux index =
253	if (index = length) then ()
254	else
255	  (Bytes.set myString index (input_char input);
256	   readStringAux (index + 1))
257  in
258  readStringAux 0;
259  Bytes.to_string myString
260
261let readLongString () =
262  let input = getInChannel() in
263  let length = readNBytes input 4 in
264  let myString = Bytes.make length ' ' in
265  let rec readStringAux index =
266	if (index = length) then ()
267	else
268	  (Bytes.set myString index (input_char input);
269	   readStringAux (index + 1))
270  in
271  readStringAux 0;
272  Bytes.to_string myString
273
274(* skip n bytes   *)
275let skipNBytes numberBytes =
276  let input = getInChannel () in
277  seek_in input ((pos_in input) + numberBytes)
278
279(* skip n words *)
280let skipNWords numberWords =
281  skipNBytes (numberWords * (getWordSize ()))
282
283(********************************************************************)
284(* functions for reading certain data structures                    *)
285(********************************************************************)
286
287(* read kind index *)
288let readKindIndex getKindFn =
289  let kindCat = readOneByte  () in
290  let kindInd = readTwoBytes () in
291  getKindFn kindCat kindInd
292
293(* read constant index *)
294let readConstantIndex getConstFn =
295  let constCat = readOneByte  () in
296  let constInd = readTwoBytes () in
297  getConstFn constCat constInd
298
299(* read a global kind *)
300let readGlobalKind ind =
301  let arity = readOneByte () in
302  let name  = readString ()   in
303  Absyn.makeGlobalKind (Symbol.symbol name) arity ind
304
305(* read a local kind *)
306let readLocalKind ind =
307  Absyn.makeLocalKind (Symbol.symbol "") (readOneByte ()) ind
308
309(* read a type skeleton *)
310let readTypeSkeleton getKindFn =
311
312  let rec readTypeSkeletonAux () =
313	let cat = readOneByte () in
314	if cat  = typeMarkArrow then               (* arrow type *)
315	  let arg = readTypeSkeletonAux () in
316	  let target = readTypeSkeletonAux () in
317	  Absyn.ArrowType(arg, target)
318	else if cat = typeMarkSkeletonVar then     (* type skeleton variable *)
319	  let offset = readOneByte () in
320	  Absyn.SkeletonVarType (ref offset)
321	else if cat = typeMarkKind then            (* sort or type application *)
322	  let kindOpt = readKindIndex getKindFn in
323	  let arity   = readOneByte () in
324	  let args    = readTypeSkeletons arity [] in
325	  if Option.isNone kindOpt then Absyn.ErrorType
326	  else
327		Absyn.ApplicationType(Option.get kindOpt, args)
328	else
329	  (Errormsg.error Errormsg.none
330		 "readTypeSkeleton: invalid type skeleton in bytecode";
331	   Absyn.ErrorType)
332
333  and readTypeSkeletons number tyskels =
334	if (number = 0) then (List.rev tyskels)
335	else
336	  readTypeSkeletons (number - 1) ((readTypeSkeletonAux ()) :: tyskels)
337  in
338  readTypeSkeletonAux ()
339
340(* read fixity *)
341let readFixity () =
342  let number = readOneByte () in
343  if (number = fixityMarkInfix) then Absyn.Infix
344  else if (number = fixityMarkInfixl) then Absyn.Infixl
345  else if (number = fixityMarkInfixr) then Absyn.Infixr
346  else if (number = fixityMarkNoFixity) then Absyn.NoFixity
347  else if (number = fixityMarkPrefix) then Absyn.Prefix
348  else if (number = fixityMarkPrefixr) then Absyn.Prefixr
349  else if (number = fixityMarkPostfix) then Absyn.Postfix
350  else Absyn.Postfixl
351
352(* read global constant *)
353let readGlobalConstant getTypeSkelFn ind =
354  let fixity    = readFixity  () in
355  let prec      = readOneByte () in
356  let tyEnvSize = readOneByte () in
357  let symbol    = Symbol.symbol (readString ()) in
358  let tySkelInd = readTwoBytes () in
359  let tySkel    = getTypeSkelFn tySkelInd in
360  Absyn.makeGlobalConstant symbol fixity prec false false tyEnvSize tySkel ind
361
362(* read local constant *)
363let readLocalConstant getTypeSkelFn ind =
364  let fixity    = readFixity  () in
365  let prec      = readOneByte () in
366  let tyEnvSize = readOneByte () in
367  let tySkelInd = readTwoBytes () in
368  let tySkel    = getTypeSkelFn tySkelInd in
369  Absyn.makeLocalConstant (Symbol.symbol "") fixity prec tyEnvSize tySkel ind
370
371(* read hidden constant *)
372let readHiddenConstant getTypeSkelFn ind =
373  let tySkelInd = readTwoBytes () in
374  let tySkel    = getTypeSkelFn tySkelInd in
375  let const     = Absyn.makeHiddenConstant tySkel 0 in
376  Absyn.setConstantIndex const ind;
377  const
378
379(* read findcode function *)
380let readFindCodeFn () = readOneByte ()
381
382(* read instruction operands *)
383let readint1 () = readOneByte ()
384let readint2 () = readTwoBytes ()
385let readint4 () = readNBytes (getInChannel ()) 4
386let readint8 () = readNBytes (getInChannel ()) 8
387
388(* read lable *)
389let getLabelFn : (int -> unit) option ref = ref None
390let setGetLabelFn func = getLabelFn := Some func
391
392(* read label *)
393let readintref4 () =
394  let offset = readWord () in
395  (Option.get (!getLabelFn)) offset;
396  (ref offset)
397
398let readintref8 () =
399  let offset = readWord () in
400  (Option.get (!getLabelFn)) offset;
401  (ref offset)
402
403(* read float *)
404let readfloat4 () =
405  let input = getInChannel () in
406  let mantissa = Int32.to_float (readNBytes2 input 4) in
407  let exponent = readNBytes input 4 in
408  let (significant, _) = frexp mantissa in
409  ldexp significant exponent
410
411(* read kind/constant *)
412let getKindFn : (int -> int -> Absyn.akind option) option ref = ref None
413let getConstantFn : (int -> int -> Absyn.aconstant option) option ref
414	= ref None
415
416let setGetKindFn func = getKindFn := Some(func)
417let setGetConstantFn func = getConstantFn := Some(func)
418
419let readakind2 () =  Option.get (readKindIndex (Option.get (!getKindFn)))
420let readaconstant2 () =
421	Option.get (readConstantIndex (Option.get(!getConstantFn)))
422
423(** ******************************************************************* **)
424(**          DISPLAY FUNCTIONS FOR DISASSEMBLY                          **)
425(** ******************************************************************* **)
426let findLabelFn : (int -> string) option ref = ref None
427let setFindLabelFn func = findLabelFn := Some func
428
429let displayR   regNum = "A" ^ (string_of_int regNum)
430let displayE   envNum = "Y" ^ (string_of_int envNum)
431let displayN   number = "#" ^ (string_of_int number)
432let displayI1  number = "#" ^ (string_of_int number)
433let displayCE  number = "Y" ^ (string_of_int number)
434let displaySEG number = "#" ^ (string_of_int number)
435let displayI   number = (string_of_int number)
436let displayF   number = (string_of_float number)
437let displayS   number = "<string #" ^ (string_of_int number) ^ ">"
438let displayMT  number = "<import #" ^ (string_of_int number) ^ ">"
439let displayIT  number = "<impl #" ^ (string_of_int number) ^ ">"
440let displayHT  number = "<hash #" ^ (string_of_int number) ^ ">"
441let displayBVT number = "<bvt #" ^ (string_of_int number) ^ ">"
442let displayL   offset = (Option.get (!findLabelFn)) (!offset)
443
444(* display a kind data *)
445let displayK kind =
446  match (Absyn.getKindType kind) with
447	  Absyn.GlobalKind -> Absyn.getKindName kind
448  | Absyn.LocalKind  ->
449	  "<local kind #" ^ (string_of_int (Absyn.getKindIndex kind)) ^ ">"
450  | Absyn.PervasiveKind -> Absyn.getKindName kind
451
452(* display a constant data *)
453let displayC const =
454  let cat = Absyn.getConstantType const in
455  match cat with
456	  Absyn.GlobalConstant -> Absyn.getConstantName const
457  | Absyn.PervasiveConstant(_) -> Absyn.getConstantName const
458  | Absyn.LocalConstant ->
459	  "<local const #" ^ (string_of_int (Absyn.getConstantIndex const)) ^ ">"
460  | Absyn.HiddenConstant ->
461	  "<hidden const #" ^ (string_of_int (Absyn.getConstantIndex const)) ^ ">"
462  | _ -> Errormsg.impossible Errormsg.none "displayaconstant2: invalid const"
463
464(* display find code function *)
465let displayFindCodeFn mark =
466  if mark = findCodeFuncMarkHash then "hash"
467  else "sequential"
468