From: Matthew Mondor Date: Thu, 10 Sep 2015 00:16:53 +0000 (+0000) Subject: Inital import of an old forgotten test X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=18a770f3903b6297d7a301e5e723596779c4c20f;p=mmondor.git Inital import of an old forgotten test --- diff --git a/mmsoftware/cl/test/ecl-fast-array.lisp b/mmsoftware/cl/test/ecl-fast-array.lisp new file mode 100644 index 0000000..26a5809 --- /dev/null +++ b/mmsoftware/cl/test/ecl-fast-array.lisp @@ -0,0 +1,180 @@ +;;;; $Id: ecl-fast-array.lisp,v 1.1 2015/09/10 00:16:53 mmondor Exp $ +;; +;; Copyright (c) 2011, Matthew Mondor. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR +;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;; IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT, +;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;; +;;;; +;;;; Implementation of C-backed efficient arrays for ECL. +;;;; Note that these cannot be used in interpreted code directly, +;;;; although slower user accessors are also provided for interpreted code. +;;;; Internally a C array is used to hold the structure data, +;;;; and CL accessors are converted to inline C. +;;;; The specialized WITH-FAST-ARRAY system has a small block-setup +;;;; overhead and provides high-performance C-inlined read and write access +;;;; to every slot of a fast array within the block. +;;;; + +#| XXX TODO XXX +|# + +(declaim (optimize (speed 3) (safety 1) (debug 3))) ;XXX + +(defpackage :fast-array + (:use :cl) + (:export #:fast-array-instance + #:make-fast-array + #:fast-array-dimension + #:copy-fast-array + #:slow-aref + #:slow-fill-pointer + #:slow-push + #:slow-pop + #:fast-array--adjust + #:fast-array-element-type + #:fast-array-element-type-p + #:with-fast-array + #:do-fast-array)) +(in-package :fast-array) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + ;; XXX Add print-object + (defstruct (fast-array-instance + (:constructor #make-fast-array-instance)) + "Every FAST-ARRAY instance is an object of type FAST-ARRAY-INSTANCE. +Its slots are reserved for internal use." + (element-type + pointer + size 0 :type fixnum + fill-pointer 0 :type fixnum)) + + ;;; Maps CL/FFI type to C type. + (defun c-type<-ecl-type (type) + (case type + (:t "cl_object") + (:fixnum "cl_fixnum") + (:int "int") + (:unsigned-int "unsigned int") + (:long "long") + (:unsigned-long "unsigned long") + (:int8-t "int8_t") + (:uint8-t "uint8_t") + (:int16-t "int16_t") + (:uint16-t "uint16_t") + (:int32-t "int32_t") + (:uint32-t "uint32_t") + (:int64-t "int64_t") + (:uint64-t "uint64_t"))) + + ;;; Maps C type to CL/FFI type. + (defun ecl-type<-type (type) + (case type + (:t 't) + (:fixnum 'fixnum) + (:short 'fixnum) + (:unsigned-short 'fixnum) + (:int 'integer) + (:unsigned-int 'integer) + (:long 'integer) + (:unsigned-long 'integer) + (:int8-t 'fixnum) + (:uint8-t 'fixnum) + (:int16-t 'fixnum) + (:uint16-t 'fixnum) + (:int32-t 'integer) + (:uint32-t 'integer) + (:int64-t 'integer) + (:uint64-t 'integer) + (otherwise nil))) + + ;;; C function needed to convert a value to the wanted CL/FFI type. + (defun c-function<-type (type field) + (format nil + (case type + (:t "ecl_make_object(~A)") ; XXX Right? + (:fixnum "ecl_make_fixnum(~A)") ; XXX Right? + (:int8-t "ecl_make_int8_t(~A)") + (:uint8-t "ecl_make_uint8_t(~A)") + (:int16-t "ecl_make_int16_t(~A)") + (:uint16-t "ecl_make_uint16_t(~A)") + (:int32-t "ecl_make_int32_t(~A)") + (:uint32-t "ecl_make_uint32_t(~A)") + (:int64-t "ecl_make_int64_t(~A)") + (:uint64-t "ecl_make_uint64_t(~A)") + (:int "ecl_make_int(~A)") + (:unsigned-int "ecl_make_unsigned_integer(~A)") + (:long "ecl_make_long(~A)") + (otherwise + (error "c-function<-type: unknown type ~A" + type))) + field)) + + ;;; Maps C-FFI or CL types to the C function to access them. + (defun to-c-function<-type (type) + (case type + (:t "ecl_to_object_t") ; XXX Right? + (:fixnum "ecl_to_fixnum_t") ; XXX Right? + (:int8-t "ecl_to_int8_t") + (:uint8-t "ecl_to_uint8_t") + (:int16-t "ecl_to_int16_t") + (:uint16-t "ecl_to_uint16_t") + (:int32-t "ecl_to_int32_t") + (:uint32-t "ecl_to_uint32_t") + (:int64-t "ecl_to_int64_t") + (:uint64-t "ecl_to_uint64_t") + (:int "ecl_to_int") + (:unsigned-int "ecl_to_unsigned_integer") + (:long "ecl_to_long") + (otherwise + (error "to-c-function<-type: unknown type ~A" + type)))) + + (defun make-fast-array (element-type initial-size + &optional (finalizer nil))) + + (defun fast-array-dimension (array)) + + (defun copy-fast-array (array &key (copy-finalizer t))) + + (defun slow-aref (array index)) + (defun (setf slow-aref) (value array index)) + + (defun slow-fill-pointer (array)) + (defun (setf slow-fill-pointer (value array))) + + (defun slow-push (value array)) + (defun slow-pop (array)) + + (defun fast-array-adjust (array new-size)) + + (defun fast-array-element-type (array)) + + (defun fast-array-element-type-p (array type))) + +;;; Define AREF/ASET macros, possibly also FILL-POINTER manipulation and +;;; PUSH/POP ones. +(defmacro with-fast-array ((prefix array) &body body)) + +(defmacro do-fast-array ((var array + &key (start 0) (end nil) (index nil)) + &body body)) \ No newline at end of file