Created
September 16, 2010 17:54
-
-
Save dmitryvk/582848 to your computer and use it in GitHub Desktop.
Test files for sbcl-win32-threads
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;(sb-alien:define-alien-routine ("odprint" odprint) sb-alien:void (msg sb-alien:c-string)) | |
(defun cons-lot (stream char) | |
;(odprint (format nil "in cons-lot, char is ~A" char)) | |
(sleep 2) | |
(loop | |
(loop repeat 1 | |
for ar = (make-array (* 1024 1024 1) :initial-element 0) | |
do (loop for i from 0 below (length ar) do (setf (aref ar i) 123))) | |
(format stream "~A" char) | |
(finish-output stream) | |
(sleep 0.1) | |
)) | |
(defun non-consing-loop (stream char) | |
(loop | |
(loop repeat (expt 10 8)) | |
(format stream "~A" char) | |
(finish-output stream) | |
(sleep 0.1))) | |
(defun threaded-cons-lot (n) | |
(loop | |
with stream = *standard-output* | |
repeat n | |
for i from 0 | |
for c = (code-char (+ i (char-code #\A))) | |
;do (odprint "creating thread") | |
do (let ((c c)) (sb-thread:make-thread (lambda () (cons-lot stream c)))) | |
;do (odprint "created thread") | |
)) | |
#+nil | |
(with-open-file (f "diasm.txt" :direction :output :if-exists :supersede) | |
(let ((*standard-output* f)) | |
(disassemble 'cons-lot))) | |
(defconstant +n+ 3) | |
(sleep 1) | |
(let ((output *standard-output*)) | |
(sb-thread:make-thread (lambda () (non-consing-loop output #\+)))) | |
(threaded-cons-lot (1- +n+)) | |
;(odprint "threads started, now cons myself") | |
(cons-lot *standard-output* (code-char (+ (1- +n+) (char-code #\A)))) | |
;(quit) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(use-package :sb-thread) | |
(declaim (optimize (debug 3)) (notinline mm ml ct mct noisefn)) | |
(defun mm () | |
(cons t t)) | |
(defun ml (mom-mark) | |
(list (make-array 24 :initial-element mom-mark))) | |
(defun ct (semaphore parent kid-mark) | |
(wait-on-semaphore semaphore) | |
(let ((old (symbol-value-in-thread 'this-is-new parent))) | |
(setf (symbol-value-in-thread 'this-is-new parent) | |
(make-array 24 :initial-element kid-mark)) | |
old)) | |
(defun mct (semaphore parent kid-mark) | |
(lambda () (ct semaphore parent kid-mark))) | |
(defvar *running* nil) | |
(defun noisefn () | |
(loop while t | |
do (setf * (make-array 1024)) | |
;; Busy-wait a bit so we don't TOTALLY flood the | |
;; system with GCs: a GC occurring in the middle of | |
;; S-V-I-T causes it to start over -- we want that | |
;; to occur occasionally, but not _all_ the time. | |
(loop repeat (random 128) | |
do (setf ** *)))) | |
;(disassemble 'noisefn) | |
(defun run () | |
(let* ((parent *current-thread*) | |
(semaphore (make-semaphore)) | |
(*running* t) | |
(noise nil)) | |
(setf noise (make-thread 'noisefn)) | |
(write-string "; ") | |
(dotimes (i 600000) | |
(when (zerop (mod i 20)) | |
(write-char #\.) | |
(force-output)) | |
(let* ((mom-mark (mm)) | |
(kid-mark (mm)) | |
(child (make-thread (mct semaphore parent kid-mark)))) | |
(progv '(this-is-new) (ml mom-mark) | |
(signal-semaphore semaphore) | |
(assert (eq mom-mark (aref (join-thread child) 0))) | |
(assert (eq kid-mark (aref (symbol-value 'this-is-new) 0)))))) | |
(setf *running* nil) | |
(join-thread noise))) | |
(run) | |
(quit) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment