(* Production of a bytecode executable file *) open Misc BasicIO Nonstdio Miscsys Obj Fnlib Const Mixture Config;open Code_dec Symtable Patch Tr_const; val autolink = ref trueval verbose  = ref false (* First pass: check the consistency of files *) fun read_file name =     let val truename = find_in_path name	val is = open_in_bin truename	val tables =	    let val n = input_binary_int is in		seek_in is n;		input_value is : compiled_unit_tables	    end	    handle x =>		(close_in is;		 msgIBlock 0;		 errPrompt "Error on file ";		 msgString truename; msgEOL();		 msgEBlock();		 raise x)	val _ = close_in is    in (truename, tables) end exception WrongStamp and NotYet fun check_file name stampOpt pending processed =   let val simplename = Filename.chop_suffix name ".uo"      val uname = normalizedUnitName(Filename.basename simplename)      val () =	  if member uname pending then	      raise Fail ("Unit " ^ name ^ " depends on itself")	  else ()      val () =	  if member uname reservedUnitNames then	      raise Fail ("Unit "^uname^" is built-in, and cannot be linked")	  else ()       val already = (SOME (Hasht.find (!watchDog) uname)) 	            handle Subscript => NONE        fun needs subuname substamp processed =	  (check_file (subuname ^ ".uo") (SOME substamp) 	              (uname :: pending) processed)	  handle WrongStamp => 	              raise Fail ("Compiled body of unit " ^ uname 				    ^ " is incompatible with unit "^ subuname)	       | NotYet => 		      raise Fail ("Unit " ^ subuname ^ " is mentioned by "				  ^ uname ^ " but not yet linked")  in       case already of	  SOME stamp' =>	      (case stampOpt of		   SOME stamp => 		       if stamp <> stamp' then raise WrongStamp 		       else processed		 | NONE =>                        (msgIBlock 0;			errPrompt "Warning: unit ";			msgString uname; 			msgString " is needed by a unit preceding it";			msgEOL();			msgEBlock();			processed))	| NONE => let val implicit = case stampOpt of NONE => false | _ => true		      val _ = if not(!autolink) andalso implicit 			      then raise NotYet else ()		      val (truename, tables) = read_file name		      val precedingUnits = 			  Hasht.fold needs processed (#cu_mentions tables)		   in 		      Hasht.insert (!watchDog) uname (#cu_sig_stamp tables);		      (uname, truename, tables) :: precedingUnits		  end  end val check_file = fn name => fn processed => check_file name NONE [] processed  (* Second pass: determine which phrases are required *) val missing_globals =    ref (Hasht.new 1 : (QualifiedIdent * int, unit) Hasht.t); fun is_in_missing g =  (Hasht.find (!missing_globals) g; true)  handle Subscript => false; fun remove_from_missing g =  Hasht.remove (!missing_globals) g; fun add_to_missing g =  Hasht.insert (!missing_globals) g (); fun is_required (Reloc_setglobal g, _) = is_in_missing g  | is_required _ = false; fun remove_required (Reloc_setglobal g, _) = remove_from_missing g  | remove_required _ = (); fun add_required (Reloc_getglobal g, _) = add_to_missing g  | add_required _ = (); fun scan_val uname (id, stamp) tolink =  let val q = {qual=uname, id=[id]} in    if is_in_missing (q, 0) then      (remove_from_missing (q, 0);       add_to_missing (q, stamp);       (id, stamp) :: tolink)    else      tolink  end; fun scan_phrase (phr : compiled_phrase) tolink =    let val (_, otherlist) = #cph_reloc phr    in 	if not (#cph_pure phr) orelse List.exists is_required otherlist then	    (List.app remove_required otherlist;	     List.app add_required otherlist;	     phr :: tolink)	else	    tolink    end; fun scan_file (uname, truename, (tables : compiled_unit_tables)) tolink =  let val exportedE = #cu_exc_ren_list tables      val valRenList = #cu_val_ren_list tables      val exportedV = foldL (scan_val uname) [] valRenList      val phraseIndex = #cu_phrase_index tables      val required = foldL scan_phrase [] phraseIndex  in    (uname, truename, required, exportedE, exportedV) :: tolink  end; (* Third pass : link in the required phrases. *) fun link_object os (uname, truename, required, exportedE, exportedV) =  let val is = open_in_bin truename in    (List.app       (fn (phr : compiled_phrase) =>         let val () = seek_in is (#cph_pos phr)             val buff = input(is, #cph_len phr)             val () = if size buff < #cph_len phr                      then raise Size else ()         in           patch_object buff 0 (#cph_reloc phr);           output(os, buff)         end)       required;     exportPublicNames uname exportedE exportedV;     close_in is)    handle x =>      (close_in is;       msgIBlock 0;       errPrompt "Error while linking file ";       msgString truename; msgEOL();       msgEBlock();       raise x)  end; (* To build the initial table of globals *) local  prim_val vector_ : int -> '_a -> '_a vector       = 2 "make_vect"  prim_val sub_    : 'a vector -> int -> 'a         = 2 "get_vect_item"  prim_val update_ : 'a vector -> int -> 'a -> unit = 3 "set_vect_item"in   fun emit_data os =    let val len = number_of_globals()        val globals = vector_ len (repr 0)    in      List.app        (fn (n,sc) => update_ globals n (translStructuredConst sc))        (!literal_table);      output_value os globals    end; end; (* To build a bytecode executable file *) val write_symbols = ref false;val no_header     = ref false;val stand_alone   = ref false; (* cvr: 144 merge *) fun reportLinked toscan =    let fun reportUnit (uname, _, _) = (msgString uname; msgString ".uo ")    in 	msgIBlock 0; 	msgString "Linking: ";	List.app reportUnit (rev toscan); 	msgEOL(); msgEBlock()    end fun link unit_list exec_name =  let val _ = missing_globals :=  (* 04Sep95 e *)               (Hasht.new 263 : (QualifiedIdent * int, unit) Hasht.t)      val toscan = foldL check_file [] unit_list      val _ = if !verbose then reportLinked toscan else ()      val tolink = foldL scan_file [] toscan      val os = if !no_header andalso not (!stand_alone) then 	           open_out_bin exec_name	       else 		   open_out_exe exec_name      fun copy name =	  let val buff = CharArray.array(4096, #"\000")	      val is = open_in_bin (Filename.concat (!path_library) name)	      fun loop () = 		  case buff_input is buff 0 4096 of		      0 => ()		    | n => (buff_output os buff 0 n; loop ())	  in 	      (loop (); close_in is) handle x => (close_in is; raise x)	  end  in     ((* Prepend the runtime system? *)      if !stand_alone then copy "camlrunm" else ();      (* Prepend the header? *)      if !no_header orelse !stand_alone then () else copy "header";      missing_globals := (* for gc -- 04Sep95 e *)       (Hasht.new 1 : (QualifiedIdent * int, unit) Hasht.t);      (* The bytecode *)      let val pos1 = pos_out os          val () = List.app (link_object os) tolink          val () = output_byte os Opcodes.STOP;          (* The table of global data *)          val pos2 = pos_out os          val () = emit_data os          (* Linker tables *)          val pos3 = pos_out os          val () =            if !write_symbols then save_linker_tables os            else ();          (* Debugging info (none, presently) *)          val pos4 = pos_out os      in        (* The trailer *)        output_binary_int os (pos2 - pos1);        output_binary_int os (pos3 - pos2);        output_binary_int os (pos4 - pos3);        output_binary_int os 0;        output(os, "ML08");        close_out os      end    ) handle x =>       (close_out os;        remove_file exec_name;        raise x)  end;