Permalink
Browse files

up

  • Loading branch information...
1 parent 05ebef9 commit f3dd5985cddd7240bf7aa175a6117134d7952783 @mathematical-systems committed Dec 28, 2011
Showing with 244 additions and 0 deletions.
  1. +2 −0 README
  2. +18 −0 cl-static-array.asd
  3. +14 −0 memo/implementation.org
  4. +1 −0 others/array-operations
  5. +1 −0 others/ffa
  6. +102 −0 src/array.lisp
  7. +9 −0 src/environment.lisp
  8. +10 −0 src/packages.lisp
  9. +2 −0 src/sequence.lisp
  10. +34 −0 src/type.lisp
  11. +37 −0 src/utils.lisp
  12. +14 −0 test/simple.lisp
View
2 README
@@ -19,3 +19,5 @@ Things need to be worried about:
- portability
+NOTE: only special and non-adjustable arrays are sensible in foreign
+arrays.
View
@@ -0,0 +1,18 @@
+(in-package :cl-user)
+
+(asdf:defsystem cl-static-array
+ :description "Native static array support for CL implementations"
+ :author "MSI"
+ :version "0.1.20100426"
+ :depends-on (:alexandria :cffi)
+ :components
+ ((:module src
+ :components ((:file "packages")
+ (:file "environment")
+ (:file "utils")
+ (:file "type" :depends-on ("utils"))
+ (:file "array" :depends-on ("type"))
+ (:file "sequence" :depends-on ("array")))
+ :serial t
+ )))
+
View
@@ -0,0 +1,14 @@
+- defun need to be shadowed for optimizing declarations.
+- maybe defmethod too?
+
+- the best way to incorporate with CL's type system?
+
+- I think we should accept two types of pointers: integer and
+ implementation dependent pointer object.
+
+- complex single-float and complex double-float?
+
+- auto free
+
+- (typep sa '(static-array double-float (*)))
+
Submodule array-operations added at 4dd37a
Submodule ffa added at b7012f
View
@@ -0,0 +1,102 @@
+(in-package :static-array)
+
+(defstruct (static-array-object
+ (:conc-name sa-))
+ pointer
+ length
+ size ; just for the convenience of passing size to foreign functions
+ dimensions
+ element-type
+ foreign-type)
+
+(defun make-static-array-from-pointer (pointer dimensions element-type)
+ (assert (find element-type +element-type-foreign-type-table+ :test 'equalp :key #'first))
+ (let* ((pointer (ensure-pointer pointer))
+ (dimensions (alexandria:ensure-list dimensions)))
+ (assert (> (length dimensions) 0)
+ nil
+ ":dimensions must be an integer or a list of integers. Current value: ~a"
+ dimensions)
+ (destructuring-bind (foreign-type element-size)
+ (cdr (assoc element-type +element-type-foreign-type-table+ :test #'equal))
+ (let* ((length (reduce #'* dimensions)))
+ (make-static-array-object :pointer pointer
+ :length length
+ :size (* element-size length)
+ :dimensions dimensions
+ :element-type element-type
+ :foreign-type foreign-type)))))
+
+(defun make-static-array (dimensions element-type
+ &key (initial-element nil initial-element-p)
+ initial-contents null-terminated-p)
+ (assert (find element-type +element-type-foreign-type-table+ :test 'equalp :key #'first))
+ (let* ((dimensions (alexandria:ensure-list dimensions))
+ (foreign-type (second (assoc element-type +element-type-foreign-type-table+ :test #'equal)))
+ (length (reduce #'* dimensions))
+ (ptr (if initial-element-p
+ (cffi:foreign-alloc
+ foreign-type
+ :count length
+ :initial-element initial-element
+ :null-terminated-p null-terminated-p)
+ (cffi:foreign-alloc
+ foreign-type
+ :count length
+ :initial-contents initial-contents
+ :null-terminated-p null-terminated-p))))
+ (assert (> (length dimensions) 0))
+ (make-static-array-from-pointer ptr dimensions element-type)))
+
+(defun compute-offset (static-array indices)
+ (assert (= (length (sa-dimensions static-array))
+ (length indices)))
+ (with-slots (dimensions) static-array
+ (let ((offset 0))
+ (declare (type array-index offset))
+ (loop for s in (sa-dimensions static-array)
+ for i in indices
+ do
+ (setf offset (+ (* offset s) i)))
+ offset)))
+
+(defun sa-aref (static-array &rest indices)
+ (declare (dynamic-extent indices))
+ (cffi:mem-aref (sa-pointer static-array)
+ (sa-foreign-type static-array)
+ (compute-offset static-array indices)))
+
+(defun (setf sa-aref) (newval static-array &rest indices)
+ (declare (dynamic-extent indices))
+ (setf (cffi:mem-aref (sa-pointer static-array)
+ (sa-foreign-type static-array)
+ (compute-offset static-array indices))
+ newval))
+
+
+;;; CL standard array function wrapper
+
+#+nil
+(defparameter +sa-type-object+
+ (let ((type (excl::type-canonicalize 'static-array-object)))
+ (assert (not (eq type t)))
+ type))
+
+(defun aref (array &rest indices)
+ (declare (dynamic-extent indices))
+ (typecase array
+ (static-array-object
+ (apply #'sa-aref array indices))
+ (otherwise
+ (apply #'cl:aref array indices))))
+
+(define-compiler-macro aref (&whole form array &rest indices &environment env)
+ (let* ((type (variable-type-information array env t)))
+ (setf foo type)
+ (cond ((eq type nil)
+ `(sa-aref ,array ,@indices))
+ ((subtypep type 'cl:array)
+ `(cl:aref ,array ,@indices))
+ (t
+ form))))
+
View
@@ -0,0 +1,9 @@
+;;;;; Portable environment wrapper
+
+(in-package :static-array)
+
+(defun variable-type-information (symbol &optional environment all-declarations)
+ #+allegro (second (find 'cl:type (nth-value 2 (sys:variable-information symbol environment all-declarations)) :key #'first))
+ #+sbcl (cdr (find 'cl:type (nth-value 2 (sb-cltl2:variable-information symbol environment)) :key #'first)))
+
+
View
@@ -0,0 +1,10 @@
+(in-package :cl-user)
+
+(defpackage :static-array
+ (:use :cl)
+ (:nicknames :sa)
+ (:shadow :aref
+ )
+ (:export :static-array
+ ))
+
View
@@ -0,0 +1,2 @@
+(in-package :static-array)
+
View
@@ -0,0 +1,34 @@
+(in-package :static-array)
+
+
+;; NOTE: The following array element-types are supported.
+;; (lisp-type cffi-type bytes)
+(defconstant +element-type-foreign-type-table+
+ '((single-float :float 4)
+ (double-float :double 8)
+ ;; (complex single-float 8)
+ ;; (complex double-float 16)
+
+ ((unsigned-byte 8) :uint8 1)
+ ((unsigned-byte 16) :uint16 2)
+ ((unsigned-byte 32) :uint32 4)
+ ((unsigned-byte 64) :uint64 8)
+
+ ((signed-byte 8) :int8 1)
+ ((signed-byte 16) :int16 2)
+ ((signed-byte 32) :int32 4)
+ ((signed-byte 64) :int64 8)
+ ))
+
+(defun ensure-element-type (element-type)
+ (find element-type +element-type-foreign-type-table+ :test #'equalp :key #'first))
+
+#+nil
+(deftype static-array (&optional element-type dimensions)
+ (assert (or (eq element-type '*) (ensure-element-type element-type)))
+ (etypecase dimensions
+ (atom 'static-array-object)
+ (list
+ (assert (every #'(lambda (d) (or (eq d '*) (integerp d))) dimensions))
+ 'static-array-object)))
+
View
@@ -0,0 +1,37 @@
+(in-package :static-array)
+
+(deftype pointer ()
+ #+64bit `(unsigned-byte 64)
+ #-64bit `(unsigned-byte 32))
+
+(deftype array-index () `(mod #.array-dimension-limit))
+
+(defmacro defun-speedy (name lambda-list &body body)
+ `(progn
+ (declaim (inline ,name))
+ (defun ,name ,lambda-list
+ (declare (optimize speed)
+ ;; #+allegro (:faslmode :immediate)
+ )
+ ,@body)
+ #+allegro
+ (define-compiler-macro ,name ,lambda-list
+ `(let (,,@(loop
+ for n in lambda-list
+ when (not (find n '(&key &optional &rest &aux)))
+ collect ``(,',n ,,n)))
+ (declare (optimize speed))
+ ,@',body))
+
+ ',name))
+
+
+(defun ensure-pointer (pointer)
+ #+allegro (progn
+ (check-type pointer integer)
+ pointer)
+ #+sbcl (etypecase pointer
+ (integer (cffi-sys:make-pointer pointer))
+ (sb-sys:system-area-pointer pointer)))
+
+
View
@@ -0,0 +1,14 @@
+(in-package :static-array)
+
+(defparameter *sa*
+ (make-static-array (list 2 3) 'double-float :initial-contents '(0d0 1d0 2d0 3d0 4d0 5d0)))
+
+(declaim (type (static-array double-float (* *)) *sa*))
+
+(defun simple-test (array index)
+ (declare (optimize speed (safety 0))
+ ;; (type (simple-array double-float (* *)) array)
+ (type (static-array double-float (* *)) array)
+ (type fixnum index))
+ (aref array 0 1)
+ (aref array index index))

0 comments on commit f3dd598

Please sign in to comment.