Lovesan/sb-net-core-crash.lisp

## sb-net-core-crash.lisp
;;; This file reproduces tha fact that SBCL crashes
;;;   while .Net runtime is loaded
;;; .Net Core SDK must be installed

;;; run the file like 'sbcl --script sb-net-core-crash.lisp'

(defun version-compare (left right)
  (labels ((parse (c)
             ;; Given .Net version naming convention,
             ;;   3.0.0 is actually greater then 3.0.0-rc1
             (or (ignore-errors (parse-integer c))
                 -1))
           (split (str &aux (end (length str)))
             (loop :with start = 0
                   :with components = '()
                   :for i :below end
                   :for c = (char str i)
                   :when (member c '(#\. #\-))
                     :do (push (subseq str start i)
                               components)
                         (setf start (1+ i))
                   :finally (unless (= start end)
                              (push (subseq str start end) components))
                            (return (nreverse (mapcar #'parse components)))))
           (cmp (a b) (cond ((> a b) 1) ((< a b) -1) (t 0)))
           (pad (list other-length)
             (let ((length (length list)))
               (if (< length other-length)
                 (append list (make-list (- other-length length)
                                         :initial-element 0))
                 list))))
    (loop :with v1 = (split left)
          :with v2 = (split right)
          :with v1-len = (length v1)
          :with v2-len = (length v2)
          :for left :on (pad v1 v2-len)
          :and right :on (pad v2 v1-len)
          :for a = (car left)
          :for b = (car right)
          :do (cond ((< a b) (return -1))
                    ((> a b) (return 1)))
          :finally (return (cond (left (cmp a 0))
                                 (right (cmp 0 b))
                                 (t 0))))))

(defun version> (left right)
  (= 1 (version-compare left right)))

(defun find-dotnet ()
  (let* ((out (with-output-to-string (s)
                (sb-ext:run-program "dotnet" '("--list-runtimes")
                                    :search t
                                    :output s)))
         (list (with-input-from-string (in out)
                 (loop :for line = (read-line in nil)
                       :while line
                       :when (search "Microsoft.NETCore.App" line)
                         :collect (let* ((ver-start (1+ (position #\Space line)))
                                         (ver-end (position #\Space line :start ver-start))
                                         (path-start (1+ (position #\[ line)))
                                         (path-end (position #\] line))
                                         (version (subseq line ver-start ver-end))
                                         (dir (merge-pathnames
                                               (make-pathname
                                                :directory (list :relative version))
                                               (truename (subseq line path-start path-end))))
                                         (lib (truename
                                               (merge-pathnames
                                                #+win32
                                                "coreclr.dll"
                                                #+linux
                                                "libcoreclr.so"
                                                #+darwin
                                                "libcoreclr.dylib"
                                                #-(or win32 linux darwin)
                                                (error "Unsupported platform")
                                                dir))))
                                    (cons version lib)))))
         (latest (first (sort list #'version> :key #'car))))
    (cdr latest)))

(defvar *coreclr-location* (find-dotnet))

(defun load-dotnet ()
  (format *error-output* "Loading ~a~%" *coreclr-location*)
  (load-shared-object *coreclr-location*))

(defvar *coreclr-lib* (load-dotnet))

(defconstant +path-separator+ #+win32 #\; #-win32 #\:)

(defun get-trusted-platform-assemblies ()
  (format nil (concatenate 'string "~{~a" "~^" (string +path-separator+) "~}")
          (directory (make-pathname :type "dll"
                                    :name :wild
                                    :defaults *coreclr-location*))))

(defvar *trusted-platform-assemblies*
  (get-trusted-platform-assemblies))

#+win32
(progn
  (sb-alien:define-alien-routine
      ("GetModuleFileNameW" get-module-file-name)
    sb-alien:unsigned-int
    (module sb-sys:system-area-pointer)
    (buffer sb-sys:system-area-pointer)
    (size sb-alien:unsigned-int))
  (defun get-exe-path ()
    ;; 1K ought to be enough for anybody
    (sb-alien:with-alien ((buf (array char 1024)))
      (get-module-file-name (sb-sys:int-sap 0)
                            (sb-alien:alien-sap buf)
                            1024)
      (sb-alien:cast buf (c-string :external-format :utf-16le)))))

#+linux
(defun get-exe-path ()
  (namestring (truename "/proc/self/exe")))

#+darwin
(progn
  (sb-alien:define-alien-routine
      ("_NSGetExecutablePath" ns-get-executable-path)
    sb-alien:int
    (buf sb-sys:system-area-pointer)
    (size sb-alien:unsigned-int))
  (defun get-exe-path ()
    ;; 1K ought to be enough for anybody
    (sb-alien:with-alien ((buf (array char 1024)))
      (ns-get-executable-path (sb-alien:alien-sap buf) 1024)
      (sb-alien:cast buf c-string))))


(sb-alien:define-alien-routine
    ("coreclr_initialize" %coreclr-initialize)
  sb-alien:unsigned-int
  (exe-path sb-alien:c-string)
  (app-domain-name sb-alien:c-string)
  (propcount sb-alien:int)
  (propkeys (array sb-alien:c-string 1))
  (propvals (array sb-alien:c-string 1))
  (host-handle sb-alien:system-area-pointer :out)
  (domain-id sb-alien:unsigned-int :out))

(defun coreclr-initialize ()
  (sb-alien:with-alien ((keys (array sb-alien:c-string 1))
                        (values (array sb-alien:c-string 1)))
    (let ((key (sb-alien:make-alien-string "TRUSTED_PLATFORM_ASSEMBLIES"))
          (value (sb-alien:make-alien-string *trusted-platform-assemblies*)))
      (setf (sb-alien:deref keys 0) key
            (sb-alien:deref values 0) value)
      (unwind-protect
           (multiple-value-bind
                 (rv host-handle domain-id)
               (%coreclr-initialize (get-exe-path) "SBCL" 1 keys values)
             (unless (zerop rv)
               (error "Unable to initialize CoreCLR: 0x~8,'0X" rv))
             (format *error-output* "Initialized CoreCLR ~%")
             (cons host-handle domain-id))
        (sb-alien:free-alien key)
        (sb-alien:free-alien value)))))

(defvar *host-domain* (coreclr-initialize))

;;; Here you'll get the crash on Linux
(dotimes (i 1000)
  (compile 'foo `(lambda (x) (+ x ,(random 100)))))
	;;; This file reproduces tha fact that SBCL crashes
	;;; while .Net runtime is loaded
	;;; .Net Core SDK must be installed

	;;; run the file like 'sbcl --script sb-net-core-crash.lisp'

	(defun version-compare (left right)
	(labels ((parse (c)
	;; Given .Net version naming convention,
	;; 3.0.0 is actually greater then 3.0.0-rc1
	(or (ignore-errors (parse-integer c))
	-1))
	(split (str &aux (end (length str)))
	(loop :with start = 0
	:with components = '()
	:for i :below end
	:for c = (char str i)
	:when (member c '(#\. #\-))
	:do (push (subseq str start i)
	components)
	(setf start (1+ i))
	:finally (unless (= start end)
	(push (subseq str start end) components))
	(return (nreverse (mapcar #'parse components)))))
	(cmp (a b) (cond ((> a b) 1) ((< a b) -1) (t 0)))
	(pad (list other-length)
	(let ((length (length list)))
	(if (< length other-length)
	(append list (make-list (- other-length length)
	:initial-element 0))
	list))))
	(loop :with v1 = (split left)
	:with v2 = (split right)
	:with v1-len = (length v1)
	:with v2-len = (length v2)
	:for left :on (pad v1 v2-len)
	:and right :on (pad v2 v1-len)
	:for a = (car left)
	:for b = (car right)
	:do (cond ((< a b) (return -1))
	((> a b) (return 1)))
	:finally (return (cond (left (cmp a 0))
	(right (cmp 0 b))
	(t 0))))))

	(defun version> (left right)
	(= 1 (version-compare left right)))

	(defun find-dotnet ()
	(let* ((out (with-output-to-string (s)
	(sb-ext:run-program "dotnet" '("--list-runtimes")
	:search t
	:output s)))
	(list (with-input-from-string (in out)
	(loop :for line = (read-line in nil)
	:while line
	:when (search "Microsoft.NETCore.App" line)
	:collect (let* ((ver-start (1+ (position #\Space line)))
	(ver-end (position #\Space line :start ver-start))
	(path-start (1+ (position #\[ line)))
	(path-end (position #\] line))
	(version (subseq line ver-start ver-end))
	(dir (merge-pathnames
	(make-pathname
	:directory (list :relative version))
	(truename (subseq line path-start path-end))))
	(lib (truename
	(merge-pathnames
	#+win32
	"coreclr.dll"
	#+linux
	"libcoreclr.so"
	#+darwin
	"libcoreclr.dylib"
	#-(or win32 linux darwin)
	(error "Unsupported platform")
	dir))))
	(cons version lib)))))
	(latest (first (sort list #'version> :key #'car))))
	(cdr latest)))

	(defvar coreclr-location (find-dotnet))

	(defun load-dotnet ()
	(format error-output "Loading ~a~%" coreclr-location)
	(load-shared-object coreclr-location))

	(defvar coreclr-lib (load-dotnet))

	(defconstant +path-separator+ #+win32 #\; #-win32 #\:)

	(defun get-trusted-platform-assemblies ()
	(format nil (concatenate 'string "~{~a" "~^" (string +path-separator+) "~}")
	(directory (make-pathname :type "dll"
	:name :wild
	:defaults coreclr-location))))

	(defvar trusted-platform-assemblies
	(get-trusted-platform-assemblies))

	#+win32
	(progn
	(sb-alien:define-alien-routine
	("GetModuleFileNameW" get-module-file-name)
	sb-alien:unsigned-int
	(module sb-sys:system-area-pointer)
	(buffer sb-sys:system-area-pointer)
	(size sb-alien:unsigned-int))
	(defun get-exe-path ()
	;; 1K ought to be enough for anybody
	(sb-alien:with-alien ((buf (array char 1024)))
	(get-module-file-name (sb-sys:int-sap 0)
	(sb-alien:alien-sap buf)
	1024)
	(sb-alien:cast buf (c-string :external-format :utf-16le)))))

	#+linux
	(defun get-exe-path ()
	(namestring (truename "/proc/self/exe")))

	#+darwin
	(progn
	(sb-alien:define-alien-routine
	("_NSGetExecutablePath" ns-get-executable-path)
	sb-alien:int
	(buf sb-sys:system-area-pointer)
	(size sb-alien:unsigned-int))
	(defun get-exe-path ()
	;; 1K ought to be enough for anybody
	(sb-alien:with-alien ((buf (array char 1024)))
	(ns-get-executable-path (sb-alien:alien-sap buf) 1024)
	(sb-alien:cast buf c-string))))


	(sb-alien:define-alien-routine
	("coreclr_initialize" %coreclr-initialize)
	sb-alien:unsigned-int
	(exe-path sb-alien:c-string)
	(app-domain-name sb-alien:c-string)
	(propcount sb-alien:int)
	(propkeys (array sb-alien:c-string 1))
	(propvals (array sb-alien:c-string 1))
	(host-handle sb-alien:system-area-pointer :out)
	(domain-id sb-alien:unsigned-int :out))

	(defun coreclr-initialize ()
	(sb-alien:with-alien ((keys (array sb-alien:c-string 1))
	(values (array sb-alien:c-string 1)))
	(let ((key (sb-alien:make-alien-string "TRUSTED_PLATFORM_ASSEMBLIES"))
	(value (sb-alien:make-alien-string trusted-platform-assemblies)))
	(setf (sb-alien:deref keys 0) key
	(sb-alien:deref values 0) value)
	(unwind-protect
	(multiple-value-bind
	(rv host-handle domain-id)
	(%coreclr-initialize (get-exe-path) "SBCL" 1 keys values)
	(unless (zerop rv)
	(error "Unable to initialize CoreCLR: 0x~8,'0X" rv))
	(format error-output "Initialized CoreCLR ~%")
	(cons host-handle domain-id))
	(sb-alien:free-alien key)
	(sb-alien:free-alien value)))))

	(defvar host-domain (coreclr-initialize))

	;;; Here you'll get the crash on Linux
	(dotimes (i 1000)
	(compile 'foo `(lambda (x) (+ x ,(random 100)))))