MODULE DevLnkWritePe;
(**	project	= "BlackBox 2.0"
	organizations	= "Oberon microsystems, BBWFC, OberonCore, BBCP Team"
	contributors	= "Contributors, Igor Dehtyarenko"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "The 2-Clause BSD License"
	changes	= "
	- 2016.11 initial version by Igor Dehtyarenko (Trurl)
	"
	issues	= "
	- ...
	"
**)

	
	IMPORT LB := DevLnkBase, Files;

	TYPE 
		Module = LB.Module;

		Section = RECORD
			size: INTEGER;
			offs: INTEGER;
			addr: INTEGER; (* rva *)
		END;
		
	VAR
		outFile: Files.File;
		out: Files.Writer;

	CONST
		cui = 3; gui = 2;
		ExeImageBase = 400000H; DllImageBase = 10000000H;
		SizeOfHeapReserve = 400000H;  (* primary heap *)  
		SizeOfHeapCommit =   10000H;
		SizeOfStackReserve = 200000H;
		SizeOfStackCommit=   10000H;
			
		SectionAlignment = 1000H;
		FileAlignment = 512;
		SizeOfHeaders = 1024;
		expDirSize = 40;
		
	VAR
		subsystem: INTEGER;  
		AddressOfEntryPoint: INTEGER;		
		NumberOfSections: INTEGER;
		TimeDateStamp: INTEGER;
		SizeOfImage : INTEGER;
		code, data, vars, rsrc, impo, expo, relo: Section; 
		impDirSize: INTEGER;
		expStrTable, impStrTable: LB.StringTable;
		outNameStrIndex: INTEGER;
		exeFlags: SET;
		
	PROCEDURE WriteCh (ch: SHORTCHAR);
	BEGIN
		out.WriteByte(SHORT(ORD(ch)))
	END WriteCh;
	
	PROCEDURE Write2 (x: INTEGER);
	BEGIN
		out.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
		out.WriteByte(SHORT(SHORT(x MOD 256)))
	END Write2;
	
	PROCEDURE Write4 (x: INTEGER);
	BEGIN
		out.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
		out.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
		out.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
		out.WriteByte(SHORT(SHORT(x MOD 256)))
	END Write4;
	
	PROCEDURE WriteStr(IN s: LB.STRING; len: INTEGER);
		VAR i: INTEGER;
	BEGIN 
		i := 0;
		WHILE s[i] # 0X DO out.WriteByte(SHORT(ORD(s[i]))); INC(i) END;
		WHILE i < len DO out.WriteByte(0); INC(i) END
	END WriteStr;

	PROCEDURE PadTo(pos: INTEGER);
	BEGIN
		WHILE out.Pos() < pos DO out.WriteByte(0) END;
	END PadTo;

(**********************************)	
	PROCEDURE Init*;
		CONST relocs_stripped = 0; executable_image = 1; 
					line_nums_stripped = 2; local_syms_stripped = 3;
					machine_32bit = 8; debug_stripped = 9; 
					removable_run_from_swap = 10; net_run_from_swap = 11;
					system = 12; dll = 13; up_system_only = 14;
	BEGIN
		LB.InitStringTable(impStrTable, 1000);
		LB.InitStringTable(expStrTable, 0);

		subsystem := gui; (* *)
		IF LB.opt.subsystem # 0 THEN 
			subsystem := LB.opt.subsystem;
		END;
		
		exeFlags := {executable_image, line_nums_stripped, debug_stripped}; 
		IF LB.outDll THEN 
			INCL(exeFlags,  dll);
			LB.ImageBase := DllImageBase;
		ELSE 
			LB.ImageBase := ExeImageBase;
		END;
		IF LB.opt.imageBase > 0 THEN 
			LB.ImageBase := LB.opt.imageBase;
		END;

		NumberOfSections := 0;

		code.size := LB.codeSize; 
		data.size := LB.dataSize;
		vars.size := LB.varsSize;

		code.addr := SectionAlignment;
		data.addr := LB.Aligned(code.addr + code.size, SectionAlignment);
		vars.addr := LB.Aligned(data.addr + data.size, SectionAlignment);

		AddressOfEntryPoint := code.addr + LB.initOffs;
	END Init;
	
(**********************************)	
	PROCEDURE GetBases*(OUT codeBase, dataBase, varsBase: INTEGER);
	BEGIN
		codeBase := code.addr + LB.ImageBase;
		dataBase := data.addr + LB.ImageBase;
		varsBase := vars.addr + LB.ImageBase;
	END GetBases;

(**********************************)	
	PROCEDURE CollectImp;
		VAR lib: Module;  sym: LB.Symbol; 
				symIdx: INTEGER;
	BEGIN
		symIdx := 0;
		lib := LB.dllList; 
		WHILE lib # NIL DO
			LB.AddDllName(impStrTable, lib.exp.name, ".dll", lib.exp.namIdx);
			lib.exp.symIdx := symIdx;
			sym := lib.exp.next; 
			WHILE sym # NIL DO
				LB.AddHintName(impStrTable, 0, sym.name, sym.namIdx);
				sym.symIdx := symIdx;
				INC(symIdx);
				sym := sym.next
			END;
			INC(symIdx);
			lib := lib.next
		END;
		impDirSize := 20 * (LB.impDllCount + 1);
		impo.size := impDirSize + 8 * (LB.impCount + LB.impDllCount) + impStrTable.len;
	END CollectImp;

	PROCEDURE CollectExport;
		VAR sym: LB.Symbol;  
	BEGIN
		IF LB.expCount > 0 THEN  
			LB.AddName(expStrTable, SHORT(LB.outputName$), outNameStrIndex);
			sym := LB.expList;
			WHILE sym # NIL DO 
				LB.AddName(expStrTable, sym.name, sym.namIdx);
				sym := sym.next
			END;
			expo.size := expDirSize + 10 * LB.expCount + expStrTable.len;
		ELSE	
			expo.size := 0;
		END;
	END CollectExport;

	PROCEDURE CalculateLayout;
		VAR 
	BEGIN
		CollectImp;
		CollectExport;
		(* rva's *)
		impo.addr := LB.Aligned(vars.addr + vars.size, SectionAlignment);
		expo.addr := LB.Aligned(impo.addr + impo.size, SectionAlignment);
		rsrc.addr := LB.Aligned(expo.addr + expo.size, SectionAlignment);
		relo.addr := LB.Aligned(rsrc.addr + rsrc.size, SectionAlignment);

		(* file pos's *)
		code.offs := LB.Aligned(SizeOfHeaders, FileAlignment); 
		data.offs := LB.Aligned(code.offs + code.size, FileAlignment);
		vars.offs := 0;
		impo.offs := LB.Aligned(data.offs + data.size, FileAlignment);
		expo.offs := LB.Aligned(impo.offs + impo.size, FileAlignment);
		rsrc.offs := LB.Aligned(expo.offs + expo.size, FileAlignment);
		relo.offs := LB.Aligned(rsrc.offs + rsrc.size, FileAlignment);		

		IF expo.size = 0 THEN expo.addr := 0; expo.offs := 0 END;
		rsrc.addr := 0;
		rsrc.size := 0;
		rsrc.offs := 0;
	END CalculateLayout;

(**********************************)
	PROCEDURE WriteSectionHeaders;
	CONST cnt_code=5; cnt_data= 6; cnt_udata= 7; discard = 25; exec = 29; read = 30; write = 31;
	TYPE 
		SectName = ARRAY 8 OF SHORTCHAR;
		
		PROCEDURE SectionHeader(IN scn: Section; name:SectName; flags:SET);
		BEGIN
			IF scn.addr # 0 THEN
				WriteStr(name, 8); 
				Write4(0); (* Misc (always 0) *)
				Write4(scn.addr);  (* VirtualAddress *)
				Write4(LB.Aligned(scn.size, FileAlignment));  (* SizeOfRawData *)
				Write4(scn.offs);  (* PointerToRawData *)
				Write4(0); (* PointerToRelocations *)
				Write4(0); (* PointerToLinenumbers *)
				Write4(0); (* NumberOfRelocations, NumberOfLinenumbers *)
				Write4(ORD(flags)); 
				
				INC(NumberOfSections)
			END 
		END SectionHeader;
		
	BEGIN
		SectionHeader(code, ".text",  {cnt_code, read, exec});
		SectionHeader(data, ".data",  {cnt_data, read, write});
		SectionHeader(vars, ".var",   {cnt_udata, read, write});
		SectionHeader(rsrc, ".rsrc",  {cnt_data, read, write});
		SectionHeader(impo, ".idata", {cnt_data, read, write});
		SectionHeader(expo, ".edata", {cnt_data, read, write});
		SectionHeader(relo, ".reloc", {cnt_data, read, discard});
	END WriteSectionHeaders;

	PROCEDURE WriteHeader;
	CONST SizeOfOptionalHeader = 224;
	
		PROCEDURE WriteDosStub;
		CONST sizeOfStub = 128; (* >= 64 *)
		BEGIN
			WriteStr('MZ',60);
			Write4(sizeOfStub); (* offset to the PE signature*)
			PadTo(sizeOfStub);
		END WriteDosStub;
		
		PROCEDURE WriteDirEntry(rva, Size: INTEGER);
		BEGIN
			Write4(rva); Write4(Size);
		END WriteDirEntry;
	
	BEGIN
		WriteDosStub;
		WriteStr("PE", 4); (* signature *)
		(* COFF header *)
		Write2(014CH); (* Machine  (386) *)
		Write2(NumberOfSections);
		Write4(TimeDateStamp);
		Write4(0); 
		Write4(0);
		Write2(SizeOfOptionalHeader);
		Write2(ORD(exeFlags)) ;
		(* 'Optional' header *)
		Write2(10BH); (* magic (normal ececutable file) *)
		WriteCh(2X); WriteCh(5X); (* linker version 2.5 *) 
		Write4(code.size); (* SizeOfCode *)
		Write4(data.size); (* SizeOfInitializedData  *)
		Write4(vars.size); (* SizeOfUninitializedData *)
		Write4(AddressOfEntryPoint); 
		Write4(code.addr); (* BaseOfCode rva *)
		Write4(data.addr); (* BaseOfData rva *)
		Write4(LB.ImageBase); 
		Write4(SectionAlignment); 
		Write4(FileAlignment); 
		Write2(5); Write2(0); (* OperatingSystemVersion (Major, Minor) *)
		Write2(4); Write2(0); (* ImageVersion *)
		Write2(5); Write2(0); (* SubsystemVersion: 5.0 - Windows 2000 *) 
		Write4(0); (* reserved = 0*)
		
		Write4(SizeOfImage); 
		Write4(SizeOfHeaders); 
		Write4(0); (* CheckSum *)
		Write2(subsystem);
		Write2(0); (* DllCharacteristics *)
		Write4(SizeOfStackReserve); 
		Write4(SizeOfStackCommit); 
		Write4(SizeOfHeapReserve); 
		Write4(SizeOfHeapCommit); 
		Write4(0);	(* LoaderFlags =0 *)

		Write4(16); (* NumberOfRvaAndSizes *)
		(* IMAGE_DIRECTORY: [16] *)
		WriteDirEntry(expo.addr, expo.size); (* Export Table *)	
		WriteDirEntry(impo.addr, impo.size); (* Import Table  *)	
		WriteDirEntry(rsrc.addr, rsrc.size); (* Resource Table *)	
		WriteDirEntry(0, 0); (* Exception Table *)	
		WriteDirEntry(0, 0); (* Certificate Table   *)	
		WriteDirEntry(relo.addr, relo.size); (* Base Relocation Table *)	
		WriteDirEntry(0, 0); (* Debug *)	
		WriteDirEntry(0, 0); (* Architecture =0  *)	
		WriteDirEntry(0, 0); (* Global Ptr, size=0 *)
		WriteDirEntry(0, 0); (* TLS Table *)
		WriteDirEntry(0, 0); (* Load Config Table *)
		WriteDirEntry(0, 0); (* Bound Import *)
		WriteDirEntry(0, 0); (* Import Address Table *)
		WriteDirEntry(0, 0); (* Delay Import Descriptor *)
		WriteDirEntry(0, 0); (* CLR Runtime Header *)
		WriteDirEntry(0, 0); (* Reserved *)
		
		WriteSectionHeaders;
	END WriteHeader;

	PROCEDURE WriteInitCode;
	BEGIN
		out.WriteBytes(LB.initMod.code.bytes, 0, LB.initMod.code.size);
	END WriteInitCode;
	
	PROCEDURE WritePlt;
	VAR lib: Module;  sym: LB.Symbol; 
	VAR thunk: INTEGER;
	BEGIN
		thunk := LB.ImageBase + impo.addr + impDirSize; (* absolute addr *)
		lib := LB.dllList; 
		WHILE lib # NIL DO
			sym := lib.exp.next; 
			WHILE sym # NIL DO
				WriteCh(0FFX); WriteCh(25X); Write4(thunk + sym.symIdx*4);	(* jmp indirect *)
				LB.AddReloc(sym.addr + 2); 
				sym := sym.next
			END;
			lib := lib.next
		END;
	END WritePlt;

	PROCEDURE WriteCode;
	VAR mod: Module; 
	BEGIN
		PadTo(code.offs);
		WriteInitCode;
		mod := LB.modList;
		WHILE mod # NIL DO 
			out.WriteBytes(mod.code.bytes, 0, mod.code.size);
			mod := mod.next
		END;
		WritePlt;
	END WriteCode;

	PROCEDURE WriteData;
		VAR mod: Module; 
	BEGIN
		PadTo(data.offs);
		mod := LB.modList; 
		WHILE mod # NIL DO
			out.WriteBytes(mod.data.bytes, 0, mod.data.size);
			mod := mod.next
		END
	END WriteData;
	
	PROCEDURE WriteImport;
		VAR i, lookup, thunk, names: INTEGER; 
		VAR lib: Module;  sym: LB.Symbol; 
	BEGIN
		PadTo(impo.offs);

		thunk := impo.addr + impDirSize; (* Address Table *)
		lookup := thunk + 4 * (LB.impCount + LB.impDllCount);  (* Lookup Table *)
		names := lookup + 4 * (LB.impCount + LB.impDllCount);  (* Hint/Name Table *)

		(* Import Directory *)
		lib := LB.dllList; 
		WHILE lib # NIL DO
			Write4(lookup + lib.exp.symIdx * 4); 
			Write4(0); (* time/data =  0 *)
			Write4(0); (* ForwarderChain *)
			Write4(names + lib.exp.namIdx); 
			Write4(thunk + lib.exp.symIdx * 4); 
			lib := lib.next
		END;		
		Write4(0); Write4(0); Write4(0); Write4(0); Write4(0);
		
		FOR i := 1 TO 2 DO	(* lookup table, name table  *)
			lib := LB.dllList; 
			WHILE lib # NIL DO
				sym := lib.exp.next; 
				WHILE sym # NIL DO Write4(names + sym.namIdx); sym := sym.next END;
				Write4(0);
				lib := lib.next
			END;		
		END;		
		LB.WriteStringTable(out, impStrTable);
	END WriteImport;
	
	PROCEDURE WriteExport;
		CONST OrdinalBase = 1;
		VAR sym: LB.Symbol; 
			functions, names, ordinals, strings, i: INTEGER; 
	BEGIN
		PadTo(expo.offs);
		
		functions := expo.addr + expDirSize; 	(* Address Table *)
		names := functions + 4 * LB.expCount;	(* Name Pointer Table *)
		ordinals := names + 4 * LB.expCount; 	(* Ordinal Table *)
		strings := ordinals+ 2 * LB.expCount;	(* Name Table *)

		(*  EXPORT_DIRECTORY *)
		Write4(0);	(* Characteristics  *)
		Write4(TimeDateStamp);	
		Write4(0);	(* version *)
		Write4(strings + outNameStrIndex);	(* Name of the DLL  *)
		Write4(OrdinalBase);	
		Write4(LB.expCount);	(* NumberOfFunctions *)
		Write4(LB.expCount);	(* NumberOfNames *)
		Write4(functions);	
		Write4(names);	
		Write4(ordinals);

		sym := LB.expList; 
		WHILE sym # NIL DO Write4(sym.addr- LB.ImageBase); sym := sym.next END; (* rva *)
		sym := LB.expList; 
		WHILE sym # NIL DO Write4(strings + sym.namIdx); sym := sym.next END;
		i := 0; WHILE i < LB.expCount DO Write2(i); INC(i) END;
		LB.WriteStringTable(out, expStrTable);
	END WriteExport;


	PROCEDURE WriteReloc;
		CONST pageSize = 4096; IMAGE_REL_BASED_HIGHLOW = 3;
		VAR i, hi, blockSize, page, limit, pad: INTEGER;
	BEGIN
		LB.SortReloc; 

		PadTo(relo.offs);
		relo.size := 0; 
		i := 0;
		WHILE i < LB.relCount DO
			page := LB.relTab[i] DIV pageSize * pageSize; 
			limit := page + pageSize;
			hi := i; 
			WHILE (hi < LB.relCount) & (LB.relTab[hi] < limit) DO INC(hi) END;
			blockSize := 8 + 2 * (hi - i);
			pad := blockSize MOD 4;
			INC(blockSize, pad);
			Write4(page - LB.ImageBase);  (* rva *)
			Write4(blockSize); 
			WHILE i < hi DO 
				Write2(LB.relTab[i] - page + IMAGE_REL_BASED_HIGHLOW * pageSize); 
				INC(i) 
			END; 
			IF pad # 0 THEN Write2(0) END;
			INC(relo.size, blockSize);
		END;
		Write4(0); Write4(0); 
		INC(relo.size, 8);

		PadTo(LB.Aligned(relo.offs + relo.size, FileAlignment));
	END WriteReloc;

	PROCEDURE WriteOut*;
		VAR res: INTEGER;
	BEGIN
		CalculateLayout;
		outFile := Files.dir.New(Files.dir.This(""), Files.ask); 
		out := outFile.NewWriter(out); 
		out.SetPos(0);
		WriteHeader; 
		WriteCode;
		WriteData;
		WriteImport;
		IF LB.expCount > 0 THEN WriteExport END;
		WriteReloc;
		SizeOfImage := LB.Aligned(relo.addr + relo.size, SectionAlignment);
		out.SetPos(0);
		WriteHeader;
		IF ~LB.error THEN
			outFile.Register(LB.outputName, LB.outputType, Files.ask, res);
			IF res # 0 THEN LB.Error('Register') END
		END
	END WriteOut;

END DevLnkWritePe.
