;;;
;;; test.lisp
;;;
;;; Scratch code file
;;;

(in-package :sorcery)

#|
The creation of a game engine is nothing more than the creation
of a number of state machines. I know this to be true. Wizardry
has a fairly obvious set for the castle, and another set for the
maze.

Let's go at this a different way. Instead of producing complete
salable indie-class games, why not produce a series of games as
a prototype and refinements? Release each new version to the web
as it comes ready, and treat it as a learning excersize. It
would also be a traffic builder, and the traffic could be
monetized straight-up with adwords. This would require producing
small standalone binaries, but that's not so bad...

SBCL/Win32 should be approaching usable come 0.9.11. It might be
usable now with a bit of patching. I could use that to build the
cross-process debugger I wanted to build a while ago. Meanwhile,
though, I should be able to produce a standalone executable with
just assembly code in it fairly easily. Binding new instruction
sets onto the SBCL assembler appears to be straightforward, and
I might not even have to do that much to start with.

The first step is to download a Win32 ASM devkit and find an
example that just calls MessageBoxA() and exits. Then figure out
how to make the SBCL assembler produce the same code, and write
some glue to spit out the executable forms. Okay, found an
example that does what I need.

The example file has an MZ header, a PE header, a section table,
a code segment, a dll import segment, and a data segment. We can
treat the MZ header as static data for now, but the PE header
and the section table appear to be fairly volatile.

The obvious next steps are to write out the assembly forms for
the code segment and to figure out how to build the dll import
table.
|#

#|
The basic process we're looking at here is using ASSEMBLE-
FRAGMENT to generate code fragments that are stored in reverse
order on *CODE-FRAGMENTS* as a list of the bytes comprising the
code and a list of fixups for that code fragment. We then grovel
through *CODE-FRAGMENTS* to find all of the foreign linkages and
generate stubs and import descriptors for them.

Once the foreign linkages have been created, we reverse the
*CODE-FRAGMENTS* to put them in the right order, and assign
positions to each fragment. We then have the length for each
section in the executable, so we can assign base addresses for
the sections and resolve addresses for all of the fixup targets.

Next, we apply all of the fixups, write out the executable file,
and call it done.

Well, that's the basic idea, at any rate.

In order to make fixup resolution easy, we only use one fixup of
each name/flavor, caching them in an equal hash table. We then
use an eq hash table to map fixups to the code fragment that
they name, and annotate the code fragment with its address when
that is finally known. This makes final linkage fairly simple.

And because we're now using a section table, we don't have
*CODE-FRAGMENTS* anymore. And we need to add a section structure
now to record things like attributes, names, base addresses, and
file offsets.
|#

#|
Okay, the basic example now works. What next? An awful lot of
stuff is hard-coded, some stuff is badly named (*LOAD-BASE*?),
and we're not very featureful yet. At the very least, we need to
add support for aligning fragments and easier ways to run the
entire process. There's also some real nastiness in the
assembler interface, and we don't have a proper MZ-stub. Real
hint ordinals for the dynamic imports might be nice as well.
|#

#|
An IMAGE_SECTION_HEADER is #x28 bytes long. Some of the fields
don't apply to us for various reasons (either not in .EXE files,
or for debug information).
 0: 8 bytes: Section name, ASCII, no terminator, NUL-pad.
 8: dword:   Byte length of section contents.
 c: dword:   RVA of section start (page aligned).
10: dword:   Byte length of section contents rounded up to sector size.
14: dword:   Byte offset of section data in file.
18: dword:   Relocation info, set to 0.
1c: dword:   Debug info, set to 0.
20: word:    Relocation info, set to 0.
22: word:    Debug info, set to 0.
24: dword:   "Characteristics" (flags).
                Set to #x60000020 for code segment.
                Set to #x40000040 for relocation or resource segment.
                Set to #xc0000040 for data segment.
|#

(defclass section ()
  ((name :initarg :name)
   (file-start :initform nil)
   (base-address :initform nil)
   (flags :initarg :flags)
   (fragments :initform nil :accessor section-fragments))
  )

(defclass code-fragment ()
  ((bytes :initarg :bytes :reader fragment-bytes)
   (fixups :initarg :fixups)
   (name :initarg :name)
   (address :initform nil)))

(defvar *fixups* nil)
(defvar *fixup-locations* nil)

(defvar *section-table* nil)

(defparameter *load-base* #x00400000)

(defun initialize-assembler ()
  (setf *fixups* (make-hash-table :test 'equal))
  (setf *fixup-locations* (make-hash-table :test 'eq))
  (setf *section-table* nil)
  (values))

(defun fixup (name flavor)
  (let ((fixup-name (list name flavor)))
    (or (gethash fixup-name *fixups*)
	(setf (gethash fixup-name *fixups*)
	      (sb-c:make-fixup name flavor)))))

(defun make-section (name file-name flags)
  (setf (getf *section-table* name)
	(make-instance 'section :name file-name :flags flags)))

(defun segment-length (name)
  (loop for fragment in (section-fragments (getf *section-table* name))
	sum (length (fragment-bytes fragment))))

(defun round-up-page (address)
  (logand #xfffff000 (+ address #xfff)))

(defun round-up-sector (address)
  (logand #xfffffe00 (+ address #x1ff)))

(defun make-fragment (bytes fixups name)
  (make-instance 'code-fragment :bytes bytes :fixups fixups :name name))

(defmacro defimport (function dll)
  `(defparameter ,function (fixup '(,dll ,function) :code)))

(defun %assemble-fragment (fixup section code)
  (let ((segment (sb-assem:make-segment))
	(sb-c::*fixup-notes* nil))
    (sb-assem:assemble (segment)
      (eval `(sb-assem:assemble ()
	      ,@code)))
    (sb-assem:finalize-segment segment)
    ;; We need to call process-back-patches once per fixup after the first,
    ;; due to a nasty assembler bug. We need to fix that sometime.
;;     (let ((annotations (sb-assem::segment-annotations segment)))
;;       (when annotations (inspect annotations)))
    (loop while (some #'sb-assem::back-patch-p
		      (sb-assem::segment-annotations segment))
	  do (sb-assem::process-back-patches segment))
;    (inspect segment)
    (let* ((buffer (let ((bits nil))
		     (sb-assem::on-segment-contents-vectorly
		      segment
		      (lambda (bit) (push bit bits)))
		     (apply #'concatenate '(vector (unsigned-byte 8)) (reverse bits))))
	   (code-fragment
	    (make-fragment buffer
			   sb-c::*fixup-notes*
			   fixup)))
      (setf (gethash fixup *fixup-locations*) code-fragment)
      (push code-fragment (section-fragments section))))
  (values))

(defmacro assemble-fragment (((&optional name (flavor :code))
			      &optional ((&key (section 'code)
					       (arglist))))
			     &body code)
  `(%assemble-fragment
    ,(when name (fixup name flavor))
    ',(getf *section-table* section)
    '((let ,(when arglist
		  (loop for arg in arglist
			for offset from 8 by 4
			collect `(,arg (sb-vm::make-ea :dword
					:base ebp
					:disp ,offset))))
	,@(loop for arg in arglist
		collect `(declare (ignorable ,arg)))
	(sb-assem:assemble ()
	  ,@code)))))

(defmacro inst (&body ruction)
  `(sb-assem:inst ,@ruction))

(defun find-flavored-fixups (flavor)
  (loop for fixup being each hash-value in *fixups*
	when (and (consp (sb-c::fixup-name fixup))
		  (eq (sb-c::fixup-flavor fixup) flavor))
	collect fixup))

(defun find-foreign-fixups ()
  (find-flavored-fixups :code)
  #+nil
  (loop for fixup being each hash-value in *fixups*
	when (and (consp (sb-c::fixup-name fixup))
		  (eq (sb-c::fixup-flavor fixup) :code))
	collect fixup))

(defun find-import-fixups ()
  (find-flavored-fixups :import)
  #+nil
  (loop for fixup being each hash-value in *fixups*
	when (and (consp (sb-c::fixup-name fixup))
		  (eq (sb-c::fixup-flavor fixup) :import))
	collect fixup))

(defun find-resource-fixups ()
  (find-flavored-fixups :resource))

(defun create-import-calls (fixups)
  (dolist (fixup fixups)
    (let* ((new-fixup (fixup (sb-c::fixup-name fixup) :import))
	   (target (sb-vm::make-ea :dword :disp new-fixup)))
      ;; Can't use macro interface to this, it doesn't respect lexicals.
      (%assemble-fragment fixup (getf *section-table* 'code)
			  `((inst jmp ,target))))))

(defun asciiz (string)
  (loop for char across string
	do (sb-assem:emit-byte (sb-assem::%%current-segment%%) (char-code char)))
  (sb-assem:emit-byte (sb-assem::%%current-segment%%) 0))

(defmacro emit-absolute-fixup (fixup)
  `(sb-vm::emit-absolute-fixup (sb-assem::%%current-segment%%) ,fixup))

(defun create-section-header (section)
  (with-slots (name file-start base-address flags fragments) section
    (let ((byte-length (loop for fragment in fragments
			     sum (length (fragment-bytes fragment))))
	  (name-length (min 8 (length name))))
      (sb-assem:assemble ()
	(dotimes (i name-length)
	  (inst byte (char-code (aref name i))))
	(dotimes (i (- 8 name-length))
	  (inst byte 0))
	(inst dword byte-length)
	(inst dword (- base-address *load-base*))
	(inst dword (round-up-sector byte-length))
	(inst dword file-start)
	(inst dword 0)
	(inst dword 0)
	(sb-vm::emit-word (sb-assem::%%current-segment%%) 0)
	(sb-vm::emit-word (sb-assem::%%current-segment%%) 0)
	(inst dword flags)))))

(defun create-import-table ()
  (let ((imports nil)
	(import-fixups (find-import-fixups)))
    (dolist (fixup import-fixups)
      (let ((fixup-name (sb-c::fixup-name fixup)))
	(pushnew (second fixup-name)
		 (getf imports (first fixup-name)))))
    ;; Create Import Address Tables.
    (%assemble-fragment (fixup (list :iat-start) :rva)
			(getf *section-table* 'imports)	nil)
    (loop for dll on imports by #'cddr
	  do (%assemble-fragment (fixup (list :first-thunk (car dll)) :rva)
				 (getf *section-table* 'imports)
				 nil)
	  do (loop for function in (cadr dll)
		   do (%assemble-fragment (fixup (list (car dll) function) :import)
					  (getf *section-table* 'imports)
					  `((emit-absolute-fixup
					     ,(fixup (list (car dll) function) :rva)))))
	  do (%assemble-fragment nil (getf *section-table* 'imports)
	       '((inst dword 0))))
    (%assemble-fragment (fixup (list :iat-end) :rva)
			(getf *section-table* 'imports)	nil)
    ;; Create IMAGE_IMPORT_DESCRIPTORs.
    (%assemble-fragment (fixup (list :import-start) :rva)
			(getf *section-table* 'imports)	nil)
    (loop for dll on imports by #'cddr
	  do (%assemble-fragment
	      nil (getf *section-table* 'imports)
	      `((emit-absolute-fixup
		 ,(fixup (list :hint-name (car dll)) :rva))
		(inst dword 0)
		(inst dword 0)
		(emit-absolute-fixup
		 ,(fixup (list (car dll)) :rva))
		(emit-absolute-fixup
		 ,(fixup (list :first-thunk (car dll)) :rva)))))
    ;; Last IMAGE_IMPORT_DESCRIPTOR (nulled fields).
    (%assemble-fragment nil (getf *section-table* 'imports)
			'((inst dword 0)
			  (inst dword 0)
			  (inst dword 0)
			  (inst dword 0)
			  (inst dword 0)))
    (%assemble-fragment (fixup (list :import-end) :rva)
			(getf *section-table* 'imports)	nil)
    ;; Create HintName arrays.
    (loop for dll on imports by #'cddr
	  do (%assemble-fragment (fixup (list :hint-name (car dll)) :rva)
				 (getf *section-table* 'imports)
				 nil)
	  do (loop for function in (cadr dll)
		   do (%assemble-fragment nil (getf *section-table* 'imports)
					  `((emit-absolute-fixup
					     ,(fixup (list (car dll) function) :rva)))))
	  do (%assemble-fragment nil (getf *section-table* 'imports)
				 '((inst dword 0))))
    ;; Create HintNames and DLL names.
    (loop for dll on imports by #'cddr
	  do (loop for function in (cadr dll)
		   do (%assemble-fragment
		       (fixup (list (car dll) function) :rva)
		       (getf *section-table* 'imports)
		       ;; FIXME: The word 0 below should be a hint ordinal.
		       `((sb-vm::emit-word (sb-assem::%%current-segment%%) 1)
			 (asciiz (symbol-name ',function)))))
	  do (%assemble-fragment (fixup (list (car dll)) :rva)
				 (getf *section-table* 'imports)
				 `((asciiz (symbol-name ',(car dll)))
				   ,(when (evenp (length (symbol-name (car dll))))
					  '(inst byte 0)))))))

(defun create-mz-header ()
  (let ((segment (sb-assem:make-segment)))
    (sb-assem:assemble (segment)
      (inst dword #x5a4d)
      (dotimes (i 14)
	(inst dword 0))
      (inst dword #xb0)
      (dotimes (i (* 7 4))
	(inst dword 0)))
    (sb-assem:finalize-segment segment)
    (sb-assem::segment-buffer segment)))

(defun create-pe-header ()
  (let ((segment (sb-assem:make-segment)))
    (sb-assem:assemble (segment)
      (inst dword #x4550) ;; 'PE\0\0' signature.
      (sb-vm::emit-word (sb-assem::%%current-segment%%) #x14c) ;; Machine i386.
      (sb-vm::emit-word (sb-assem::%%current-segment%%)
			(ash (length *section-table*) -1)) ;; Number of sections.
      (inst dword 0) ;; Timestamp.
      (inst dword 0) ;; Symbol table.
      (inst dword 0) ;; Number of symbols.
      (sb-vm::emit-word (sb-assem::%%current-segment%%) #xe0) ;; "Optional" header size.
      (sb-vm::emit-word (sb-assem::%%current-segment%%) #x010f) ;; Characteristics. See winnt.h.
      (sb-vm::emit-word (sb-assem::%%current-segment%%) #x10b) ;; Magic.
      (inst byte 0) ;; linker version major.
      (inst byte 0) ;; linker version minor.
      (inst dword #x200) ;; Size of code? (should calculate from section table)
      (inst dword #x400) ;; Size of idata? (maybe inclues import table?)
      (inst dword 0) ;; Size of bss.
      (inst dword (- (fixup-target-address (fixup 'start :code))
		     *load-base*)) ;; Entry point RVA.
      (inst dword #x1000) ;; Base of Code RVA (should calculate)
      (inst dword #x2000) ;; Base of Data RVA (is import table)
      (inst dword *load-base*) ;; Image base.
      (inst dword #x1000) ;; Section Alignment.
      (inst dword #x200) ;; File Alignment.
      (sb-vm::emit-word (sb-assem::%%current-segment%%) 4) ;; OS major version
      (sb-vm::emit-word (sb-assem::%%current-segment%%) 0) ;; OS minor version
      (sb-vm::emit-word (sb-assem::%%current-segment%%) 0) ;; Image major version
      (sb-vm::emit-word (sb-assem::%%current-segment%%) 0) ;; Image minor version
      (sb-vm::emit-word (sb-assem::%%current-segment%%) 4) ;; Subsystem major version
      (sb-vm::emit-word (sb-assem::%%current-segment%%) 0) ;; Subsystem minor version
      (inst dword 0) ;; Reserved
      (inst dword #x4000) ;; Size of Image (should calculate)
      (inst dword #x400) ;; Size of Headers (depends on number of sections)
      (inst dword 0) ;; Checksum (ignore)
      (sb-vm::emit-word (sb-assem::%%current-segment%%) 2) ;; Subsystem (2 = WINDOWS_GUI)
      (sb-vm::emit-word (sb-assem::%%current-segment%%) 0) ;; DLL stuff. Obsolete.
      (inst dword #x100000) ;; Stack reserve.
      (inst dword #x1000) ;; Stack commit.
      (inst dword #x100000) ;; Heap reserve.
      (inst dword #x1000) ;; Heap commit.
      (inst dword 0) ;; Loader flags. Obsolete.
      (inst dword #x10) ;; Number of data directory entries.
      (let* ((import-start (fixup-target-address
			    (fixup (list :import-start) :rva)))
	     (import-end (fixup-target-address
			  (fixup (list :import-end) :rva)))
	     (import-entry (cons (- import-start *load-base*)
				 (- import-end import-start)))
	     (iat-start (fixup-target-address
			 (fixup (list :iat-start) :rva)))
	     (iat-end (fixup-target-address
		       (fixup (list :iat-end) :rva)))
	     (iat-entry (cons (- iat-start *load-base*)
			      (- iat-end iat-start)))
	     (resource-entry nil))
	(dolist (entry (list nil import-entry resource-entry nil
			     nil nil nil nil
			     nil nil nil nil
			     iat-entry nil nil nil))
	  (if entry
	      (progn (inst dword (car entry))
		     (inst dword (cdr entry)))
	      (progn (inst dword 0)
		     (inst dword 0)))))
      (loop for section on *section-table* by #'cddr
	    do (create-section-header (cadr section))))
    (sb-assem:finalize-segment segment)
    (sb-assem::segment-buffer segment)))

(defun reverse-section-table ()
  (setf *section-table*
	(loop with r = nil
	      for (k v) on *section-table* by #'cddr
	      do (setf (getf r k) v)
	      finally (return r))))

(defun position-sections ()
  (reverse-section-table)
  (let ((file-offset #x400)
	(memory-offset (+ *load-base* #x1000))
	(length nil))
    (loop for section-info on *section-table* by #'cddr
	  do (setf length (segment-length (car section-info)))
	  do (setf (slot-value (cadr section-info)
			       'file-start) file-offset)
	  do (setf (slot-value (cadr section-info)
			       'base-address) memory-offset)
	  do (setf file-offset (round-up-sector (+ file-offset length)))
	  do (setf memory-offset (round-up-page (+ memory-offset length))))))

(defun position-fragments ()
  (loop for section on *section-table* by #'cddr
	do (with-slots (fragments base-address) (cadr section)
	     (setf fragments (reverse fragments))
	     (loop for fragment in fragments
		   with address = base-address
		   do (setf (slot-value fragment 'address) address)
		   do (incf address (length (slot-value fragment 'bytes)))))))

(defun fixup-target-address (fixup)
  (slot-value (gethash fixup *fixup-locations*) 'address))

(defun apply-one-fixup (fragment fixup-note)
  ;; Okay, here's where we have to deal with the mess we made.
  ;; There are two :KINDs of fixup-note, :ABSOLUTE and :RELATIVE.
  ;; :RELATIVE is easy to fix up, just apply the offset from the
  ;; byte -after- the fixup.
  ;; The behavior of :ABSOLUTE fixups depends on the :FLAVOR of
  ;; the fixup. If it's an :RVA fixup, it needs to be biased by
  ;; the VMA of the MZ header. Otherwise, it's a straight-up VMA.
  ;; If it's a straight-up VMA then we probably should emit a
  ;; base relocation for it. But we're not emitting relocatable
  ;; code yet, so we don't.
  (let* ((bytes (slot-value fragment 'bytes))
	 (position (sb-c:fixup-note-position fixup-note))
	 (fixup (sb-c:fixup-note-fixup fixup-note))
	 (target-fragment (gethash fixup *fixup-locations*))
	 (target-address (slot-value target-fragment 'address)))
    (flet ((apply-fixup-bytes (data)
	     (setf (aref bytes (+ position 0)) (ldb (byte 8  0) data))
	     (setf (aref bytes (+ position 1)) (ldb (byte 8  8) data))
	     (setf (aref bytes (+ position 2)) (ldb (byte 8 16) data))
	     (setf (aref bytes (+ position 3)) (ldb (byte 8 24) data))))
      (case (sb-c:fixup-note-kind fixup-note)
	(:relative
	 (apply-fixup-bytes (- target-address (slot-value fragment 'address) position 4)))
	(:absolute
	 (apply-fixup-bytes (if (eq (sb-c:fixup-flavor fixup) :rva)
				(- target-address *load-base*)
				target-address)))
	(t (error "Unknown fixup-note kind ~A"
		  (sb-c:fixup-note-kind fixup-note)))))))

(defun apply-fixups ()
  (loop for section on *section-table* by #'cddr
	do (loop for fragment in (slot-value (cadr section) 'fragments)
		 do (loop for fixup in (slot-value fragment 'fixups)
			  do (apply-one-fixup fragment fixup)))))

(defun output-to-file (filename)
  (with-open-file (output filename
			  :direction :output
			  :element-type '(unsigned-byte 8)
			  :if-exists :supersede)
    (write-sequence (create-mz-header) output)
    (write-sequence (create-pe-header) output)
    (loop for section on *section-table* by #'cddr
	  do (progn
	       (file-position output (slot-value (cadr section) 'file-start))
	       (loop for fragment in (slot-value (cadr section) 'fragments)
		     do (write-sequence (slot-value fragment 'bytes)
					output))))
    (let ((position (file-position output)))
      (when (/= position (round-up-sector position))
	(file-position output (1- (round-up-sector position)))
	(write-byte 0 output)))))

(defun create-resource-directory ()
  #+nil
  (let ((resources (find-resource-fixups)))
    ))

(defun file-resource (resource-name resource-type resource filename)
  )

(defun assemble-file (sourcefile &optional (binfile nil binfilep))
  (unless binfilep
    (setf binfile #p"/home/nyef/test-file.exe"))
  (initialize-assembler)

  (load sourcefile)

  (create-import-calls (find-foreign-fixups))
  (create-import-table)
  (create-resource-directory)
  (position-sections)
  (position-fragments)
  (apply-fixups)
  (output-to-file binfile))

;;; Registers.

(defparameter eax sb-vm::eax-tn)
(defparameter ecx sb-vm::ecx-tn)
(defparameter edx sb-vm::edx-tn)
(defparameter ebx sb-vm::ebx-tn)
(defparameter esp sb-vm::esp-tn)
(defparameter ebp sb-vm::ebp-tn)
(defparameter esi sb-vm::esi-tn)
(defparameter edi sb-vm::edi-tn)

(defparameter ax sb-vm::ax-tn)
(defparameter cx sb-vm::cx-tn)
(defparameter dx sb-vm::dx-tn)
(defparameter bx sb-vm::bx-tn)
(defparameter sp sb-vm::sp-tn)
(defparameter bp sb-vm::bp-tn)
(defparameter si sb-vm::si-tn)
(defparameter di sb-vm::di-tn)

(defparameter al sb-vm::al-tn)
(defparameter cl sb-vm::cl-tn)
(defparameter dl sb-vm::dl-tn)
(defparameter bl sb-vm::bl-tn)
(defparameter ah sb-vm::ah-tn)
(defparameter ch sb-vm::ch-tn)
(defparameter dh sb-vm::dh-tn)
(defparameter bh sb-vm::bh-tn)

;;; Structure types

(defun data-width (width)
  (case width
    (:dword 4)))

(defmacro define-structure (name options &body fields)
  (declare (ignorable options))
  (let* ((offset 0)
	 (field-lookup (loop for (width fieldname) in fields
			     collect fieldname
			     collect offset
			     do (incf offset (data-width width)))))
    (setf (get name 'sizeof) offset
	  (get name 'fields) field-lookup))
  (values))

(defun field-offset (structure field)
  (getf (get structure 'fields) field))

(defun sizeof (structure)
  (get structure 'sizeof))

;;; Test code begins here.

;(assemble-file "test1.lap" "test1.exe")

#|
(initialize-assembler)

(load "test1.lap")

;; Magic happens here.

(create-import-calls (find-foreign-fixups))
(create-import-table)
(position-sections)
(position-fragments)
(apply-fixups)
(output-to-file #p"/home/nyef/test-file.exe")
|#

;(sb-assem:inst call (sb-vm::make-ea :dword :disp (sb-c:make-fixup '(|USER32.dll| |ExitProcess|) :import)))

;;; EOF
