;;;
;;; ecoff.lisp
;;;
;;; eCOFF object file utilities.
;;;

(cl:in-package :axp-tools)


;;;; Dynamic linking information

(defparameter *dynamic-array-tags*
  '(0 (dt_null ignored)
    1 (dt_needed d_val)
    3 (dt_pltgot d_ptr)
    4 (dt_hash d_ptr)
    5 (dt_strtab d_ptr)
    6 (dt_symtab d_ptr)
    10 (dt_strsz d_val)
    11 (dt_syment d_val)
    12 (dt_init d_ptr)
    13 (dt_fini d_ptr)
    14 (dt_soname d_val)
    15 (dt_rpath d_val)
    16 (dt_symbolic ignored)
    17 (dt_rel d_ptr)
    18 (dt_relsz d_val)
    19 (dt_relent d_val)
    #x70000001 (dt_rld_version d_val)
    #x70000002 (dt_time_stamp d_val)
    #x70000003 (dt_ichecksum d_val)
    #x70000004 (dt_iversion d_val)
    #x70000005 (dt_flags d_val)
    #x70000006 (dt_base_address d_ptr)
    #x70000007 (dt_msym d_ptr)
    #x70000008 (dt_conflict d_ptr)
    #x70000009 (dt_liblist d_ptr)
    #x7000000a (dt_local_gotno d_val)
    #x7000000b (dt_conflictno d_val)
    #x70000010 (dt_liblistno d_val)
    #x70000011 (dt_symtabno d_val)
    #x70000012 (dt_unrefextno d_val)
    #x70000013 (dt_gotsym d_val)
    #x70000014 (dt_hipageno d_val)
    #x70000017 (dt_so_suffix d_val)))

(defparameter *dynamic-section-indices*
  '(#x0000 shn_undef
    #xff00 shn_acommon
    #xff01 shn_text
    #xff02 shn_data
    #xfff1 shn_abs
    #xfff2 shn_common))

(defparameter *dynamic-symbol-types*
  '(0 stt_notype
    1 stt_object
    2 stt_func
    3 stt_section
    4 stt_file))

(defparameter *dynamic-symbol-bindings*
  '(0 stb_local
    1 stb_global
    2 stb_weak
    13 stb_duplicate))

(defun dump-dynamic-header (header-section)
  (dotimes (i (floor (length header-section) 16))
    (let* ((d_tag (file-utils:u32le@ header-section (+ (* i 16) 0)))
	   (d_val (file-utils:u32le@ header-section (+ (* i 16) 8)))
	   (d_ptr (file-utils:u64le@ header-section (+ (* i 16) 8)))
	   (tag (getf *dynamic-array-tags* d_tag)))
      (ecase (cadr tag)
	(ignored
	 (format t "~A~%" (car tag)))
	(d_val
	 (format t "~15A #x~(~X~)~%" (car tag) d_val))
	(d_ptr
	 (format t "~15A #x~(~16,'0X~)~%" (car tag) d_ptr))
	(t (format t "unknown tag #x~(~X~)~%" d_tag))))))

(defun dump-dynamic-symbols (dynsym-section dynstr-section)
  (dotimes (i (floor (length dynsym-section) 24))
    (let* ((offset (* i 24))
	   (st_name (u32le@ dynsym-section (+ offset 0)))
	   (st_value (u64le@ dynsym-section (+ offset 8)))
	   (st_size (u32le@ dynsym-section (+ offset 16)))
	   (st_info (u8@ dynsym-section (+ offset 20)))
	   (st_shndx (u16le@ dynsym-section (+ offset 22)))
	   (name (sb-ext:octets-to-string
		  dynstr-section :start st_name
		  :end (position 0 dynstr-section
				 :start st_name)))
	   (symtype (getf *dynamic-symbol-types*
			  (ldb (byte 4 0) st_info)
			  "unknown"))
	   (symbind (getf *dynamic-symbol-bindings*
			  (ldb (byte 4 4) st_info)
			  "unknown"))
	   (section-index (getf *dynamic-section-indices* st_shndx "unknown")))
      (format t "~11A ~11A ~13A ~@? #x~8,'0X ~A~%"
	      section-index symtype symbind
	      (if (and (eq section-index 'shn_undef) (zerop st_value))
		  "                  ~*"
		  "#x~16,'0X")
	      st_value st_size name))))


;;;; Symbol table information

;;; An eCOFF symbol table is stored in part of the file that is not
;;; loaded by default.  It consists of a symbolic header followed by
;;; some number of descriptor table, symbol table and string sections.
;;; The symbolic header can be found by means of a pointer in the file
;;; header, and the remaining data can be found via pointers in the
;;; symbolic header.
;;;
;;; Very little of the data in each section makes any sense without
;;; the context of one or more other sections.  In order to make it
;;; easier to explore the data, we build wrappers for each of the
;;; major table entries, linking in the appropriate context at each
;;; step.

(define-file-structure ecoff-file-header ()
  (|f_magic| u16le@ #x00)
  (|f_nscns| u16le@ #x02)
  (|f_timdat| s32le@ #x04)
  (|f_symptr| u64le@ #x08)
  (|f_nsyms| u32le@ #x10)
  (|f_opthdr| u16le@ #x14)
  (|f_flags| u16le@ #x16))

(define-file-structure ecoff-symbolic-header ()
  (|magic|  u16le@ #x00)
  (|vstamp| u16le@ #x02)
  (|ilineMax|  u32le@ #x04)
  (|idnMax|    u32le@ #x08)
  (|ipdMax|    u32le@ #x0c)
  (|isymMax|   u32le@ #x10)
  (|ioptMax|   u32le@ #x14)
  (|iauxMax|   u32le@ #x18)
  (|issMax|    u32le@ #x1c)
  (|issExtMax| u32le@ #x20)
  (|ifdMax|    u32le@ #x24)
  (|crfd|      u32le@ #x28)
  (|iextMax|   u32le@ #x2c)
  (|cbLine|        u64le@ #x30)
  (|cbLineOffset|  u64le@ #x38)
  (|cbDnOffset|    u64le@ #x40)
  (|cbPdOffset|    u64le@ #x48)
  (|cbSymOffset|   u64le@ #x50)
  (|cbOptOffset|   u64le@ #x58)
  (|cbAuxOffset|   u64le@ #x60)
  (|cbSsOffset|    u64le@ #x68)
  (|cbSsExtOffset| u64le@ #x70)
  (|cbFdOffset|    u64le@ #x78)
  (|cbRfdOffset|   u64le@ #x80)
  (|cbExtOffset|   u64le@ #x88))

(define-file-structure ecoff-file-descriptor-entry ()
  (|adr|          u64le@ #x00)
  (|cbLineOffset| u64le@ #x08)
  (|cbLine|       u64le@ #x10)
  (|cbSs|         u64le@ #x18)
  (|rss|       u32le@ #x20)
  (|issBase|   u32le@ #x24)
  (|isymBase|  u32le@ #x28)
  (|csym|      u32le@ #x2c)
  (|ilineBase| u32le@ #x30)
  (|cline|     u32le@ #x34)
  (|ioptBase|  u32le@ #x38)
  (|copt|      u32le@ #x3c)
  (|ipdFirst|  u32le@ #x40)
  (|cpd|       u32le@ #x44)
  (|iauxBase|  u32le@ #x48)
  (|caux|      u32le@ #x4c)
  (|rfdBase|   u32le@ #x50)
  (|crfd|      u32le@ #x54)
  (|lang|       bitfield u16le@ #x58 (byte 5 0))
  (|fMerge|     bitfield u16le@ #x58 (byte 1 5))
  (|fReadin|    bitfield u16le@ #x58 (byte 1 6))
  (|fBigendian| bitfield u16le@ #x58 (byte 1 7))
  (|gLevel|     bitfield u16le@ #x58 (byte 2 8))
  (|fTrim|      bitfield u16le@ #x58 (byte 1 10))
  (|reserved|   bitfield u16le@ #x58 (byte 5 11))
  (|vstamp| u16le@ #x5a)
  (|reserved2| u32le@ #x5c))

(define-file-structure ecoff-local-symbol-entry ()
  (|value|    u64le@ #x00)
  (|iss|      s32le@ #x08)
  (|st|       bitfield u32le@ #x0c (byte 6 0))
  (|sc|       bitfield u32le@ #x0c (byte 5 6))
  (|reserved| bitfield u32le@ #x0c (byte 1 11))
  (|index|    bitfield u32le@ #x0c (byte 20 12)))

;; eCOFF debugging data is stored in several tables, most of which
;; have per-file subtables.  Most entries in per-file subtables make
;; no sense without the context given by the file descriptor that owns
;; it.  The context given by the file descriptor only makes sense when
;; combined with the overall context given by the symbolic header.
;; For example, a procedure descriptor gives its name as a symbol
;; index, which is relative to the per-file symbol table.  The file
;; descriptor gives a count of the symbols in its table and the index
;; within the main symbol table at which its subtable begins.

;; Procedure Descriptors
;; Local Symbols
;; Auxiliary Symbols
;; Local Strings
;; External Strings
;; File Descriptors
;; Relative File Descriptors
;; External Symbols
;; Optimization Symbols
;; Line Numbers

(defun parse-ecoff-debugging-data (ecoff-file-data)
  (let* ((f_symptr (field-value ecoff-file-data 'ecoff-file-header '|f_symptr|))
	 (f_nsyms (field-value ecoff-file-data 'ecoff-file-header '|f_nsyms|))
	 (symbolic-header-data (data-section ecoff-file-data f_symptr f_nsyms)))
    (with-fields
	  (|cbLine|    |cbLineOffset|  |ipdMax|  |cbPdOffset|
	   |isymMax|   |cbSymOffset|   |ioptMax| |cbOptOffset|
	   |iauxMax|   |cbAuxOffset|   |issMax|  |cbSsOffset|
	   |issExtMax| |cbSsExtOffset| |ifdMax|  |cbFdOffset|
	   |crfd|      |cbRfdOffset|   |iextMax| |cbExtOffset|)
	(symbolic-header-data ecoff-symbolic-header)
      (format t "Lines: ~D@~X~%" |cbLine| |cbLineOffset|)
      (format t "Procs: ~D@~X~%" |ipdMax| |cbPdOffset|)
      (format t "LSyms: ~D@~X~%" |isymMax| |cbSymOffset|)
      (format t "OSyms: ~D@~X~%" |ioptMax| |cbOptOffset|)
      (format t "ASyms: ~D@~X~%" |iauxMax| |cbAuxOffset|)
      (format t "LStrs: ~D@~X~%" |issMax| |cbSsOffset|)
      (format t "EStrs: ~D@~X~%" |issExtMax| |cbSsExtOffset|)
      (format t "Files: ~D@~X~%" |ifdMax| |cbFdOffset|)
      (format t "RFils: ~D@~X~%" |crfd| |cbRfdOffset|)
      (format t "Esyms: ~D@~X~%" |iextMax| |cbExtOffset|))))

(defclass ecoff-symbolic-header ()
  ((root-file :initarg :root-file)
   (header-section :initarg :header-section)
   (file-descriptors)
   (procedure-descriptors)))

(defclass ecoff-file-descriptor ()
  ((data-section :initarg :data-section)
   (symbolic-header :initarg :symbolic-header)
   (procedure-descriptors)))

(defclass ecoff-procedure-descriptor ()
  ((data-section :initarg :data-section)
   (file-descriptor)))

(defclass ecoff-local-symbol ()
  ((data-section :initarg :data-section)
   (name)
   (file-descriptor)))

(defun find-ecoff-symbolic-header (ecoff-file-data)
  (let ((header-section (data-section ecoff-file-data
				      (u64le@ ecoff-file-data 8)
				      (u32le@ ecoff-file-data 16))))
    (assert (= (u16le@ header-section 0) #x1992)) ;; hdrr.magic == "magicSym"
    (make-instance 'ecoff-symbolic-header
		   :root-file ecoff-file-data
		   :header-section header-section)))

(defun build-ecoff-file-descriptors (symbolic-header)
  (with-slots (root-file header-section) symbolic-header
    (with-fields (|ifdMax| |cbFdOffset|)
	(header-section ecoff-symbolic-header)
      (let ((descriptors (make-array |ifdMax|)))
	(dotimes (i |ifdMax|)
	  (let ((data (data-section root-file (+ |cbFdOffset| (* i #x60)) #x60)))
	    (setf (aref descriptors i)
		(make-instance 'ecoff-file-descriptor
			       :symbolic-header symbolic-header
			       :data-section data))))
	descriptors))))

(defun build-ecoff-procedure-descriptors (symbolic-header)
  (with-slots (root-file header-section) symbolic-header
    (with-fields (|ipdMax| |cbPdOffset|)
	(header-section ecoff-symbolic-header)
      (let ((descriptors (make-array |ipdMax|)))
	(dotimes (i |ipdMax|)
	  (let ((data (data-section root-file (+ |cbPdOffset| (* i #x40)) #x40)))
	    (setf (aref descriptors i)
		  (make-instance 'ecoff-procedure-descriptor
				 :data-section data))))
	descriptors))))

(defun build-ecoff-file-procedure-descriptors (file-descriptor)
  (with-slots (symbolic-header data-section) file-descriptor
    (with-fields (|ipdFirst| |cpd|)
	(data-section ecoff-file-descriptor-entry)
      ;;(format t "~A: ~D ~D~%" file-descriptor |ipdFirst| |cpd|)
      (unless (zerop |cpd|)
	(let ((descriptors (subseq (ecoff-procedure-descriptors symbolic-header)
				   |ipdFirst| (+ |ipdFirst| |cpd|))))
	  (loop
	     for descriptor across descriptors
	     do (setf (slot-value descriptor 'file-descriptor) file-descriptor))
	  descriptors)))))

(defmacro define-lazy-build-function (name object slot)
  `(defun ,name (,object)
     (with-slots (,slot) ,object
       (if (slot-boundp ,object ',slot)
	   ,slot
	   (setf ,slot (,(intern (format nil "BUILD-~A" name)) ,object))))))

(define-lazy-build-function ecoff-file-descriptors
    symbolic-header file-descriptors)

(define-lazy-build-function ecoff-procedure-descriptors
    symbolic-header procedure-descriptors)

(define-lazy-build-function ecoff-file-procedure-descriptors
    file-descriptor procedure-descriptors)


;;; EOF
