Initial commit

Author: Dmitry Ignatiev

.gitignore

@@ -0,0 +1 @@
+*.fasl

COPYRIGHT

@@ -0,0 +1,21 @@
+Copyright (C) 2015, Dmitry Ignatiev <lovesan.ru at gmail.com>
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use, copy,
+modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.

README.md

@@ -0,0 +1,6 @@
+Common Lisp Runtime
+===================
+
+Because we need one...
+
+...Work in progress

clr.asd

@@ -0,0 +1,41 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+;;; Copyright (C) 2015, Dmitry Ignatiev <lovesan.ru at gmail.com>
+
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defsystem #:clr
+  :version "0.1.0"
+  :description "Common Lisp Runtime"
+  :author "Dmitry Ignatiev <lovesan.ru at gmail.com>"
+  :maintainer "Dmitry Ignatiev <lovesan.ru at gmail.com>"
+  :licence "MIT",
+  :depends-on ()
+  :serial t
+  :components ((:module "src"                        
+                :serial t
+                :components (;(:file "package")
+                             ;(:file "impl-sbcl")
+                             ;(:file "cl-threadpool")
+                             ))))
+
+;; vim: ft=lisp et
+

load.lisp

@@ -0,0 +1,23 @@
+(in-package #:cl-user)
+
+(flet ((cl-file (f) (load (compile-file (truename f)))))
+  (cl-file "src/clr.lisp")
+  #+sbcl
+  (cl-file "src/impl-sbcl.lisp")
+  #-(or sbcl)
+  (error "Implementation not supported"))
+
+(flet ((cl-file (f) (load (compile-file (truename f)))))
+  (cl-file "src/base-types.lisp")
+  (cl-file "src/utils.lisp")
+  (cl-file "src/collections.lisp")
+  (cl-file "src/iterators.lisp")
+  (cl-file "src/queue.lisp")
+  (cl-file "src/stack.lisp")
+  (cl-file "src/concurrent-stack.lisp")
+  (cl-file "src/ffi.lisp")
+  #+clr:windows
+  (cl-file "src/ffi-windows.lisp")
+  (cl-file "src/threading.lisp")
+  (cl-file "src/thread-pool.lisp")
+  )

src/base-types.lisp

@@ -0,0 +1,41 @@
+(in-package #:clr)
+
+(deftype simple-char-string () '(simple-array character (*)))
+
+(deftype int8 () '(signed-byte 8))
+
+(deftype uint8 () '(unsigned-byte 8))
+
+(deftype int16 () '(signed-byte 16))
+
+(deftype short () 'int16)
+
+(deftype uint16 () '(unsigned-byte 16))
+
+(deftype ushort () 'uint16)
+
+(deftype int32 () '(signed-byte 32))
+
+(deftype int () 'int32)
+
+(deftype uint32 () '(unsigned-byte 32))
+
+(deftype uint () 'uint32)
+
+(deftype int64 () '(signed-byte 64))
+
+(deftype long () #+clr:windows 'int32 #-clr:windows 'int64)
+
+(deftype long-long () 'int64)
+
+(deftype uint64 () '(unsigned-byte 64))
+
+(deftype ulong () #+clr:windows 'uint32 #-clr:windows 'uint64)
+
+(deftype ulong-long () 'uint64)
+
+(deftype intptr () '(signed-byte #+clr:x32 32 #+clr:x64 64))
+
+(deftype uintptr () '(unsigned-byte #+clr:x32 32 #+clr:x64 64))
+
+(deftype index () '(integer 0 #.most-positive-fixnum))

src/clr.lisp

@@ -0,0 +1,37 @@
+(in-package #:cl-user)
+
+(defpackage #:clr
+  (:use #:cl)
+  (:export
+
+   ;;; features
+   #:sbcl
+   #:x32
+   #:x64
+   #:x86
+   #:x86-64
+   #:windows
+   #:unix
+
+   ;;; base types
+   #:int8
+   #:uint8
+   #:int16
+   #:short
+   #:uint16
+   #:ushort
+   #:int32
+   #:int
+   #:uint32
+   #:uint
+   #:int64
+   #:long
+   #:long-long
+   #:uint64
+   #:ulong
+   #:ulong-long
+   #:intptr
+   #:uintptr
+   #:simple-char-string
+   #:index
+   ))

src/collections.lisp

@@ -0,0 +1,33 @@
+(in-package #:cl-user)
+
+(defpackage #:clr.collections
+  (:use #:cl #:clr #:clr.impl #:clr.utils)
+  (:export
+   #:queue
+   #:queue-p
+   #:make-queue
+   #:queue-add
+   #:queue-remove
+   #:queue-peek
+   #:queue-clear
+   #:queue-size
+   #:queue-empty-p
+   #:stack
+   #:stack-p
+   #:make-stack
+   #:stack-push
+   #:stack-pop
+   #:stack-clear
+   #:stack-peek
+   #:stack-size
+   #:stack-empty-p
+   #:concurrent-stack
+   #:make-concurrent-stack
+   #:cstack-p
+   #:cstack-push
+   #:cstack-peek
+   #:cstack-pop
+   #:cstack-clear
+   #:cstack-size
+   #:cstack-empty-p
+   ))

src/concurrent-stack.lisp

@@ -0,0 +1,50 @@
+(in-package #:clr.collections)
+
+(defstruct (concurrent-stack
+            (:constructor %make-cstack)
+            (:predicate cstack-p)
+            (:conc-name %cst-))
+  (size 0 :type index)
+  (head '() :type list))
+
+(defun make-concurrent-stack ()
+  (%make-cstack))
+
+(defun cstack-push (cstack value)
+  (declare (type concurrent-stack cstack))
+  (loop :with new = (cons value nil)
+        :for head = (%cst-head cstack) :do
+          (setf (cdr new) head)
+          (when (eq head (compare-exchange (%cst-head cstack) head new))
+            (atomic-incf (%cst-size cstack))
+            (return cstack))))
+
+(defun cstack-pop (cstack)
+  (declare (type concurrent-stack cstack))
+  (loop :for head = (%cst-head cstack)
+        :for next = (cdr head) :do
+          (when (null head)
+            (return (values nil nil)))
+          (when (eq head (compare-exchange (%cst-head cstack) head next))
+            (atomic-decf (%cst-size cstack))
+            (return (values (car head) t)))))
+
+(defun cstack-peek (cstack)
+  (declare (type concurrent-stack cstack))
+  (let ((head (%cst-head cstack)))
+    (if head
+      (values (car head) t)
+      (values nil nil))))
+
+(defun cstack-size (cstack)
+  (declare (type concurrent-stack cstack))
+  (%cst-size cstack))
+
+(defun cstack-empty-p (cstack)
+  (declare (type concurrent-stack cstack))
+  (zerop (%cst-size cstack)))
+
+(defun cstack-clear (cstack)
+  (declare (type concurrent-stack cstack))
+  (setf (%cst-size cstack) 0
+        (%cst-head cstack) '()))

src/ffi-windows.lisp

@@ -0,0 +1,32 @@
+(in-package #:cl-user)
+
+(defpackage #:clr.ffi.impl
+  (:use #:cl #:clr #:clr.impl #:clr.ffi)
+  (:export
+   #:cpu-count))
+
+(in-package #:clr.ffi.impl)
+
+(defclib kernel32 "kernel32.dll")
+
+(defmacro syscall (name &rest args-and-types)
+  `(ffcall (,name :library kernel32 :convention :stdcall) ,@args-and-types))
+
+(defcstruct system-info
+  (oem-id :uint32)
+  (page-size :uint32)
+  (min-alloc :pointer)
+  (max-alloc :pointer)
+  (act-proc-mask :uintptr)
+  (num-proc :uint32)
+  (proc-type :uint32)
+  (alloc-gran :uint32)
+  (proc-level :uint32)
+  (proc-rev :uint32))
+
+(defun cpu-count ()
+  "Returieves current CPU count"
+  (with-cptr (p system-info)
+    (unless (syscall "GetSystemInfo" :pointer p :bool)
+      (error "Unable to get system information"))
+    (cslot p system-info num-proc)))