implementation module CommonObjectToDisk;

import
	StdEnv;
	
import ExtString;
import xcoff;

from Relocations import relocate_text;

import

	State,
	SymbolTable;

USE_FREADSTRING use_freadstring normal :== normal; //use_freadstring

:: *WriteOutputRecord = {
		file_or_memory	:: !Int
	,	offset			:: !Int
	,	string			:: !{#Char}
	,	file_n			:: !Int
	,	module_n		:: !Int
	,	state			:: !*State
	};

class Target2 a
where
{
	WriteOutput :: !WriteOutputRecord !*a -> (!*State,*a)
};

/*
:: WriteState = {
		n_symbol_index_lists	:: !Int			// .text, .data and (possible) user sections
	,	do_relocations			:: !Bool
	,	data_buffer				:: *{#Char}
	,	user_buffer				:: *{#Char}
	};
	
:: *UserBuffer = {
		ub_section_name			:: !String
	,	ub_buffer				:: *{#Char}
	};
	
	*/
//WriteCode 
import PlatformLinkOptions;

:: *WriteState = {
		do_relocations	:: !Bool
	,	buffers			:: !*{*{#Char}}
	,	buffers_i		:: !*{#Int}
	,	text_offset		:: !Int
	,	text_buffer		:: !*{#Char}
	};
	
DefaultWriteState :: !*WriteState;
DefaultWriteState
	= { WriteState |
		do_relocations	= True
	,	buffers			= {}
	,	buffers_i		= {}
	,	text_offset		= 0
	,	text_buffer		= {}
	};
		
	
import Sections, utilities;

WriteCode :: !*File !*PlatformLinkOptions !*State !*Files -> (!*File,!*PlatformLinkOptions,!*State,!*Files,!*WriteState);
WriteCode pe_file platform_link_options state=:{n_xcoff_files} files
	#! ws
		= DefaultWriteState;
		
	// Create buffers
	#! (buffers,buffers_i,platform_link_options)
		= create_buffers platform_link_options;
	#! ws
		= { ws &
			buffers		= buffers
		,	buffers_i	= buffers_i
		};
				
	#! (ws,pe_file,state,files)
		= write_code 0 0 ws pe_file state files;
		
	= (pe_file,platform_link_options,state,files,ws);
where {
	write_code :: !Int !Int !*WriteState !*File !*State !*Files -> !*(!*WriteState,!*File,!*State,!*Files);
	write_code file_n first_symbol_n ws pe_file state files
		| file_n >= n_xcoff_files
			= (ws,pe_file,state,files);
	
		// open xcoff file
		#! (file_name, state)
			= select_file_name file_n state;
		#! (n_symbols, state)
			= select_n_symbols file_n state;
		#! (ok,xcoff_file,files)	
			= fopen file_name FReadData files;
		| not ok
			= abort ("Cannot read file: "+++ file_name);
			
		// ?
		#! (ws,pe_file,state,xcoff_file,file_n,first_symbol_n)
			= write_optimized ws pe_file state xcoff_file file_n first_symbol_n file_name;
		
		// close xcoff file
		#! (ok,files) 				
			= fclose xcoff_file files;
		| not ok
			= abort ("Error while reading file: "+++file_name);
		= write_code (inc file_n) first_symbol_n ws pe_file state files;
} // WriteCode

write_optimized :: !*WriteState !*File !*State !*File !Int Int !String -> !*(!*WriteState,!*File,!*State,!*File,!Int,!Int);
write_optimized ws pe_file state=:{n_xcoff_files} xcoff_file file_n first_symbol_n file_name
	#! (ws,pe_file,state,xcoff_file)
		= select_symbol_index_lists_to_write ws pe_file state xcoff_file file_n first_symbol_n;

/*
	| inc file_n == n_xcoff_files
		= (ws,pe_file,state,xcoff_file,file_n,first_symbol_n);
		
		#! (file_name2, state)
			= select_file_name (inc file_n) state
		#! (n_symbols, state)
			= select_n_symbols file_n state;
		| file_name2 == file_name
			= write_optimized ws pe_file state xcoff_file (inc file_n) (first_symbol_n+n_symbols) file_name;
*/			
		#! (n_symbols, state)
			= select_n_symbols file_n state;

			= (ws,pe_file,state,xcoff_file,file_n,first_symbol_n + n_symbols); 
import RWSDebugChoice;

write_code_to_pe_files :: !Int !Bool !Int !Int !(!Int,!Int) !State !Bool !*a !*Files -> ((!*a,!(!Int,!Int),!State),!*Files) | Target2 a;
write_code_to_pe_files n_xcoff_files do_relocations file_n first_symbol_n offset0 state one_pass_link pe_file files
	| file_n >= n_xcoff_files
		= ((pe_file,offset0,state),files);
	
	# (file_name, state)
		= select_file_name file_n state;
	# (n_symbols, state)
		= select_n_symbols file_n state;
	# (ok,xcoff_file,files)	
		= fopen file_name FReadData files;
	| not ok //<<- file_name
		= abort ("Cannot read file: "+++ file_name);
	
		# (file_n,first_symbol_n,state,offset,xcoff_file,pe_file) 
			= write_code file_name file_n do_relocations first_symbol_n offset0 state xcoff_file pe_file;
	
		#! (end1,xcoff_file)
			= fposition xcoff_file;	
			
		# (ok,files) 				
			= fclose xcoff_file files;
		| not ok
			= abort ("Error while reading file: "+++file_name);

//			# (pe_file,offset,state,files)	
				= write_code_to_pe_files n_xcoff_files do_relocations (inc file_n) first_symbol_n offset state one_pass_link pe_file files;
			
//			= (pe_file,state,files);
where
{
	/*
	** file_n < n_xcoff_files
	*/
	write_code file_name file_n do_relocations first_symbol_n offset0 state xcoff_file pe_file
		#! (state,offset,xcoff_file,pe_file) 
			= write_code_to_pe_file file_n do_relocations first_symbol_n offset0 state xcoff_file pe_file;
		| next_file_n == n_xcoff_files
			= (file_n,first_symbol_n,state,offset,xcoff_file,pe_file);
					
			#! (file_name2, state)
				= select_file_name next_file_n  state
			# (n_symbols, state)
				= select_n_symbols file_n state;
			| file_name2 == file_name
				= write_code file_name next_file_n do_relocations (first_symbol_n+n_symbols) offset state xcoff_file pe_file;
				
				= (file_n,first_symbol_n + n_symbols,state,offset,xcoff_file,pe_file);
			
			
		where
		{
			next_file_n 
				= inc file_n
		
		}
				
}	

//import DebugUtilities;
F a b :== b;
	
// Auxillary functions
/*
	#! (ws,pe_file,state,xcoff_file)
		= write_symbol_index_lists ws pe_file state xcoff_file file_n first_symbol_n;
*/
select_symbol_index_lists_to_write :: !*WriteState !*File !*State !*File !Int !Int -> !*(!*WriteState,!*File,!*State,!*File);
select_symbol_index_lists_to_write ws=:{text_offset} pe_file state xcoff_file file_n first_symbol_n
	// select text symbols
	#! (text_symbols,state)		
		= selacc_text_symbols file_n state;
	#! (ws,pe_file,state,xcoff_file,text_offset)
		= write_symbol_index_lists (-1) text_symbols text_offset ws pe_file state xcoff_file;
	
	// select data symbols
	#! (data_offset,ws)
		= ws!buffers_i.[0];
	
	#! (data_symbols,state)		
		= selacc_data_symbols file_n state;
	#! (ws,pe_file,state,xcoff_file,data_offset)
		= write_symbol_index_lists 0 data_symbols data_offset ws pe_file state xcoff_file;
		
	#! ws
		= { ws & text_offset = text_offset, buffers_i.[0] = data_offset };
		
		
	// other symbols
	#! (extra_sections,state)
		= state!xcoff_a.[file_n].symbol_table.extra_sections;
	#! (ws,pe_file,state,xcoff_file)
		= foldSt write_user_symbol_index_list extra_sections (ws,pe_file,state,xcoff_file);
/*
		extra_sections	:: [ExtraSection]
	};
	
:: ExtraSection 
	= { 
		es_name			:: !String
	,	es_flags		:: !Int
	,	es_symbols		:: !SymbolIndexList
	,	es_buffer_n		:: !Int
	};	
*/
		
	= (ws,pe_file,state,xcoff_file);
where {
	write_user_symbol_index_list extra_section=:{es_buffer_n,es_symbols} (ws,pe_file,state,xcoff_file)
		#! (user_offset,ws)
			= ws!buffers_i.[es_buffer_n];
		#! (ws,pe_file,state,xcoff_file,user_offset)
			= write_symbol_index_lists es_buffer_n es_symbols user_offset ws pe_file state xcoff_file;
		#! ws
			= {ws & buffers_i.[es_buffer_n] = user_offset}
			
		= (ws,pe_file,state,xcoff_file);
	//	= abort "aa";

	write_symbol_index_lists :: !Int !SymbolIndexList !Int !*WriteState !*File !*State !*File -> !*(*WriteState,!*File,!*State,!*File,!Int);
	write_symbol_index_lists _ EmptySymbolIndex offset ws pe_file state xcoff_file
		= (ws,pe_file,state,xcoff_file,offset);
	write_symbol_index_lists buffer_n (SymbolIndex module_n symbol_list) offset ws pe_file state xcoff_file
		#! (symbol, state) 
		  	= sel_symbol file_n module_n state;
		#! (marked, state)
			= selacc_marked_bool_a (first_symbol_n+module_n) state;
		| marked 
			#! (ws,pe_file,state,xcoff_file,offset)
				= /*F (toString offset +++ (if (buffer_n == 0) " data"  " text"))*/ write_symbol_module_to_pe_file symbol offset ws pe_file state xcoff_file;
			= write_symbol_index_lists buffer_n symbol_list offset ws pe_file state xcoff_file;
			= write_symbol_index_lists buffer_n symbol_list offset ws pe_file state xcoff_file;
	where {
		sel_data_buffer :: !Int !*WriteState -> !*(!*{#Char},!*WriteState);
		sel_data_buffer buffer_n ws=:{buffers}
			#! (buffer_n1,buffers)
				= replace buffers buffer_n {};
			= (buffer_n1,{ws & buffers = buffers});
			
		sel_text_buffer :: !*WriteState -> !*(!*{#Char},!*WriteState);
		sel_text_buffer ws=:{text_buffer}
			= (text_buffer,{ws & text_buffer = {} });
			
		write_symbol_module_to_pe_file :: !Symbol !Int !*WriteState !*File !*State !*File -> !*(!*WriteState,!*File,!*State,!*File,!Int);
		write_symbol_module_to_pe_file (Module virtual_module_offset length virtual_address file_offset n_relocations relocations) offset ws=:{do_relocations} pe_file state xcoff_file
			#! (real_module_offset,state) 
				= selacc_module_offset_a (first_symbol_n+module_n) state;

			#!(ok,xcoff_file)			
				= fseek xcoff_file file_offset FSeekSet;
			|  not ok
				= abort "write_symbol_module_to_pe_file: failed seek";
				
			#! (start,text_a0,xcoff_file,ws)
				= case (USE_FREADSTRING ((True) && (buffer_n <> (-1))) False) of {
					True
						#! (buffer,ws)
							= sel_data_buffer buffer_n ws;
						#! aligned_offset
							= roundup_to_multiple offset 4;
						#! (length2,buffer,xcoff_file)
							= freadsubstring aligned_offset length buffer xcoff_file;
						-> (aligned_offset,buffer,xcoff_file,ws);
					False
					/*
						// NEW ...						
						#! (text_buffer,ws)
							= sel_text_buffer ws;
						#! (s_text_buffer,text_buffer)
							= usize text_buffer;
			 			#! text_buffer
							= case (s_text_buffer < length) of {
								True
									// alloc text buffer
									-> createArray length ' ';
								False
									-> text_buffer;
								}
						#! (_,text_buffer,xcoff_file)
							= freadsubstring 0 length text_buffer xcoff_file;
						-> (0,text_buffer,xcoff_file,ws);
						
						// ... NEW
						*/
					
						// /* OLD ...
						#! (text_a0,xcoff_file)	
							= freads xcoff_file length;
						-> (0,text_a0,xcoff_file,ws);
						//*/
				}

//ORIGINEEL1
/*
			#! (text_a0,xcoff_file)	
				= freads xcoff_file length;
			#! start
				= 0
*/
			// relocate if necessary
			#! (text_a0,state)  //(offset,pe_file,state)
				= case do_relocations of {
					False
						->(text_a0,state);
					True
						#! (text_a1,state)
							= relocate_text module_n length  /* end of JMP */ start 0 n_relocations file_n virtual_module_offset real_module_offset first_symbol_n state text_a0 virtual_address relocations;
						-> (text_a1,state);
				};
				
			// write
			#! aligned_offset
				= roundup_to_multiple offset 4;
			#! (pe_file,ws)
				= case (buffer_n == (-1)) of {
					True
						#! pe_file
							= write_nop_bytes (aligned_offset - offset) pe_file;		
						// /* OLD ...
						#! pe_file
							= fwrites text_a0 pe_file;
						
						
						/*
						#! (text_a0,pe_file)
							= fwritesubstring 0 length text_a0 pe_file;
						#! ws
							= { ws & text_buffer = text_a0 };
						*/
						-> (pe_file,ws);
					False
						#! ws
							= USE_FREADSTRING { ws & buffers = {ws.buffers & [buffer_n] = text_a0} } (copy 0 text_a0 aligned_offset ws);
							
//					#! (_,ws)
//							= copy 0 text_a0 aligned_offset ws;
						-> (pe_file,ws);
				};
			= (ws,pe_file,state,xcoff_file,aligned_offset + length );
		where {
			copy :: !Int !{#Char} !Int *WriteState -> /*!*(!Int,*/ !*WriteState; // );
			copy i s j d
				| i == size s
					= d; //= (j,d);
					= copy (inc i) s (inc j) {d & buffers.[buffer_n].[j /*+ 0 */] = s.[i]};		
		} // write_symbol_module_to_pe_file
	} // write_symbol_index_lists
	
	write_nop_bytes :: !Int !*File -> !*File;
	write_nop_bytes i file
		| i == 0
			= file;
		= write_nop_bytes (dec i) (fwritec '\0' file);			
}

import ExtInt;

write_code_to_pe_file :: !Int !Bool !Int (!Int,!Int) !State !*File !*a -> (!State,(!Int,!Int),!*File,!*a) | Target2 a;
write_code_to_pe_file file_n do_relocations first_symbol_n (text_offset0,data_offset0) state xcoff_file pe_file	
	#! (text_symbols,state)		
		= selacc_text_symbols file_n state;
	#! (state,text_offset,xcoff_file,pe_file)
		= write_text_to_pe_file Text text_symbols text_offset0 state xcoff_file pe_file;
		
	#! (data_symbols,state)
		= selacc_data_symbols file_n state;
	#! (state,data_offset,xcoff_file,pe_file)
		= write_text_to_pe_file Data data_symbols data_offset0 state xcoff_file pe_file;
			
	= (state,(text_offset,data_offset),xcoff_file,pe_file);
	 
	// =	write_text_to_pe_file symbols offset0 state xcoff_file pe_file;
	{
		zz Text = 0;
		zz Data = 1;
	
		write_text_to_pe_file :: !SymbolIndexListKind !SymbolIndexList !Int !State !*File !*a -> (!State,!Int,!*File,!*a) | Target2 a;
		write_text_to_pe_file _ EmptySymbolIndex offset0 state xcoff_file pe_file
			= (state,offset0,xcoff_file,pe_file);
		write_text_to_pe_file mode1 (SymbolIndex module_n symbol_list) offset0 state xcoff_file pe_file
			# (symbol, state) 
			  	= sel_symbol file_n module_n state;
			# (marked, state)
				= selacc_marked_bool_a (first_symbol_n+module_n) state;
			| marked
				# (state, offset1,xcoff_file,pe_file) 
					= write_text_module_to_pe_file symbol offset0 state xcoff_file pe_file; // <<- ("marked",marked);
				= write_text_to_pe_file mode1 symbol_list offset1 state xcoff_file pe_file;
				= write_text_to_pe_file mode1 symbol_list offset0 state xcoff_file pe_file;
			{}{
				write_text_module_to_pe_file :: !Symbol !Int !State !*File !*a -> !(!State,!Int,!*File,!*a) | Target2 a;
				write_text_module_to_pe_file (Module virtual_module_offset length virtual_address file_offset n_relocations relocations)
						offset0 state xcoff_file pe_file
					
				# (real_module_offset,state) 
					= selacc_module_offset_a o_i state;
					 
					
				# (ok,xcoff_file)			
					= fseek xcoff_file file_offset FSeekSet;
				|  not ok
						# (file_name, state1)
							= select_file_name file_n state;
					= abort ("write_text_module_to_pe_file: could not seek in file " +++ file_name +++
					         "\n This error results because the application is staically linked");

				// JMP ...	
				// only in case of dynamic linking text symbols
				# (text_a0,xcoff_file)
					= case ((n_relocations * SIZE_OF_RELOCATION) <> size relocations) of {
						True
							#! text_a0_with_extra_jmp
								= { (createArray length '\0') & [length - 5] = toChar 0xe9 };
							#! (_,text_a0_with_extra_jmp,xcoff_file)
								= freadsubstring 0 (length - 5) text_a0_with_extra_jmp xcoff_file;
							-> F ("yep1; file_n: " +++ toString file_n +++ " module_n:" +++ hex_int module_n) (text_a0_with_extra_jmp,xcoff_file);
						False
							#! (text_a0,xcoff_file)	
								= freads xcoff_file length;
							-> (text_a0,xcoff_file);
					}
				// ... JMP
					 
//				# (text_a0,xcoff_file)	
//					= freads xcoff_file length;
				
# (file_name, state)
			= select_file_name file_n state;
					
				| F("^" +++ (toString file_n) +++ "^^" +++  file_name) size text_a0==length
					#! write_output_record
						= { WriteOutputRecord |
							file_or_memory	= (zz mode1),
							offset			= offset0,
							string			= text_a1 
							
							/*
							case do_relocations of {
												True
													-> text_a1; //(write_nop_bytes (aligned_offset0-offset0) text_a1);
												False
													-> text_a1;
												}
												*/
							,	file_n		= file_n
							,	module_n	= module_n
							,	state		= state1	
						  };
					#! (state2,pe_file)
						= WriteOutput write_output_record pe_file;
						  			
					= (state2,aligned_offset0+length,xcoff_file,pe_file);			
						{						
							aligned_offset0=(offset0+alignment_mask) bitand (bitnot alignment_mask);
							alignment_mask=dec (1<<alignment);
							alignment=2;
							
							(text_a1,state1) 
								= case (do_relocations) of 
								{
									True 
//										-> relocate_text 0 state text_a0;
																		-> 	relocate_text module_n length /* end of JMP */ 0 0 n_relocations file_n virtual_module_offset real_module_offset 
	
	first_symbol_n state text_a0
	virtual_address
	relocations;
									_	-> (text_a0,state); //abort "No relocations permitted";
								}
					}
					
				{
					o_i=first_symbol_n+module_n;
				}
			}
			

	
	}
	
write_nop_bytes :: !Int !{#Char} -> !{#Char};
write_nop_bytes n string 
	= (createArray n (toChar 0x90)) +++ string;
		

	
select_data_or_code_symbols :: !SymbolIndexListKind !Int !State -> (!SymbolIndexList,!State);
select_data_or_code_symbols Text file_n state = selacc_text_symbols file_n state;
select_data_or_code_symbols Data file_n state = selacc_data_symbols file_n state;