(define-alien-routine dlopen (* t) (filename c-string) (flag int))
(define-alien-routine dlerror c-string)
(define-alien-routine dlsym (* t) (handle (* t)) (symbol c-string))

(defvar *glibc-so* (dlopen "libc.so.6" 1))
(defvar *gcc-so* (dlopen "libgcc_s.so.1" #x101))

;; Register frame info
(declaim (inline %register-frame %deregister-frame))

(defvar *%register-frame* (cast (dlsym *gcc-so* "__register_frame") (* (function void (* t)))))

(sb-alien:define-alien-routine ("__register_frame" %register-frame) 
			       void
			       (frame (* t)))
(sb-alien:define-alien-routine ("__deregister_frame" %deregister-frame) 
			       void
			       (frame (* t)))

(defun register-frame (frame-data)
  (let ((raw-frame-data (sb-alien:make-alien unsigned-char (1+ (length frame-data)))))
    (dotimes (i (length frame-data))
      (setf (deref raw-frame-data i) (aref frame-data i)))
    (setf (deref raw-frame-data (length frame-data)) 0) ; terminating 0
    (alien-funcall *%register-frame* raw-frame-data)
    raw-frame-data))

;; Test glibc's backtrace function.
(declaim (inline %backtrace-symbols-fd dlopen dlsym))
(sb-alien:define-alien-routine ("backtrace_symbols_fd" %backtrace-symbols-fd) 
			       void
			       (array (sb-alien:array (* t) nil)) (size sb-alien:int) (fd sb-alien:int))


(declaim (type (alien (* (function int (array (* t) nil) int))) *real-backtrace*))
(defvar *real-backtrace* (cast (dlsym *glibc-so* "backtrace") (* (function int (array (* t) nil) int))))


(defun glibc-backtrace (array)
  (declare (optimize (safety 0) (speed 3) (debug 0)))
  (declare (type (alien (* (array (* t) 1000))) array))
  (alien-funcall *real-backtrace* (sb-alien:deref array) 1000))

(defun do-backtrace ()
  (let* ((alien-array (sb-alien:make-alien (array (* t) 1000)))
	 (len (glibc-backtrace alien-array)))
    (%backtrace-symbols-fd (sb-alien:deref alien-array) len 1)
    (free-alien alien-array)))

(defun test ()
  (declare (optimize (safety 0) (speed 3) (debug 0)))
;  (undefined-function)
  (do-backtrace)
  (values))
    

;; This is a terrible hack; this unwind info is *nowhere near* the
;; right thing.  BUT! it does just so happen to result in the correct
;; backtrace at the point of the call from do-backtrace to
;; glibc-backtrace.
(defun register-glibc-backtrace-unwind-info ()
  (let ((segment (first (sb-disassem::get-fun-segments #'glibc-backtrace))))
    (register-frame (with-emit-output (emit-unwind-info
     (make-unwind-info
      :default-cfis (list
		     (make-cfi :opcode +DW-CFA-def-cfa+ :arg1 +dw-reg-rbp+ :arg2 0) ; base is in rbp
		     (make-cfi :opcode +DW-CFA-offset+ :arg1 +dw-reg-ra+ :arg2 2)) ; ra is up two locs on the stack
      :fdes (list (make-fde :addr-start (sb-disassem::seg-virtual-location segment)
			    :addr-len (sb-disassem::seg-length segment)))))))))