;;; -*- Mode: COMMON-LISP; Syntax: Common-Lisp; Package: TSDB -*-

;;;
;;; [incr tsdb()] --- Competence and Performance Profiling Environment
;;; Copyright (c) 1996 -- 2020 Stephan Oepen (oe@ifi.uio.no)
;;; Copyright (c) 2005 -- 2006 Erik Velldal (erikve@ifi.uio.no)
;;; Copyright (c) 2020 John Carroll (J.A.Carroll@sussex.ac.uk)
;;;
;;; This program is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
;;; the Free Software Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but WITHOUT
;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;; License for more details.
;;; 

(in-package :tsdb)

(defparameter *bdb-cache-size*
  #-(or :64bit :64-bit) 200
  #+(or :64bit :64-bit) 1024)

#+:allegro
(def-foreign-call db_open
    ((file (* :char) string)
     (createp :int integer)
     (cache :int integer))
  :returning :int
  :strings-convert t)

#+:sbcl
(define-alien-routine ("db_open" db_open) int
  (file c-string)
  (createp int)
  (cache int))

(defun open-fc (file &optional mode
                &key createp (verbose t)
                     (cache *bdb-cache-size*))
  (declare (ignore mode))

  (when (and (pathnamep file) (null (pathname-type file)))
    (setf file (merge-pathnames file (make-pathname :type "bdb"))))
  
  (let* ((cache (if (numberp cache) (* cache 1024 1024) (* 128 1024 1024)))
         (fc (make-fc :file file :cache cache)))
    (setf (fc-db fc)
      (cond
       (createp
        (when verbose
          (let* ((file (pathname file))
                 (name (file-namestring file)))
            (format
             t
             "~&[~a] open-fc(): new BDB `~a'.~%"
             (current-time :long :short) name)))
        (when (probe-file file) (delete-file file))
        (db_open (namestring file) 1 cache))
       (t
        (db_open (namestring file) 0 cache))))
    (unless (>= (fc-db fc) 0)
      (error
       "open-fc(): error ~a for `~a'."
       (fc-db fc) (namestring file)))
    fc))

#+:allegro
(def-foreign-call db_close
    ((handle :int integer))
  :returning :void)

#+:sbcl
(define-alien-routine ("db_close" db_close) void
  (handle int))

(defun close-fc (fc &key gcp)
  (when (numberp (fc-db fc))
    (db_close (fc-db fc)))
  (setf (fc-db fc) nil)
  (when gcp #+:allegro (excl:gc) #+:sbcl (sb-ext:gc)))

#+:allegro
(def-foreign-call db_cursor_close
    ((chandle :int integer))
  :returning :void)

#+:sbcl
(define-alien-routine ("db_cursor_close" db_cursor_close) void
  (chandle int))

#+:allegro
(def-foreign-call db_write_feature_int
    ((handle :int integer)
     (iid :int integer) (rid :int integer) (tid :int integer)
     (parameters :int integer) (nparameters :int integer)
     (code :int integer) (count :int integer))
  :returning :int)

#+:sbcl
(define-alien-routine ("db_write_feature_int" db_write_feature_int) int
  (handle int)
  (iid int) (rid int) (tid int)
  (parameters (array int nil)) (nparameters int)
  (code int) (count int))

#+:allegro
(def-foreign-call db_write_feature_float
    ((handle :int integer)
     (iid :int integer) (rid :int integer) (tid :int integer)
     (parameters :int integer) (nparameters :int integer)
     (code :int integer) (count :float single-float))
  :returning :int)

#+:sbcl
(define-alien-routine ("db_write_feature_float" db_write_feature_float) int
  (handle int)
  (iid int) (rid int) (tid int)
  (parameters (array int nil)) (nparameters int)
  (code int) (count single-float))

(defun db_write_feature (db iid rid tid
                         parameters nparameters code count)
  (typecase count
    (integer
     (db_write_feature_int
      db iid rid tid parameters nparameters code count))
    (float
     (db_write_feature_float
      db iid rid tid parameters nparameters code count))
    (t
     (error "db_write-feature(): invalid count `~(~a~)'." count))))

(let (#+:allegro (foo (allocate-fobject '(:array :int 2) :c)))

  (defun store-feature (fc iid rid feature)
    ;;
    ;; _fix_me_
    ;; on the surface at least, this code appears not thread safe: it probably
    ;; should wrap a process lock around the whole function.    (29-feb-09; oe)
    ;;
    (unless (numberp (fc-db fc))
      (error "store-feature(): invalid feature cache handle."))
    (when (> (length (feature-parameters feature)) 2)
      (error
       "store-feature(): excessive parameter list (~a); see `bdb.lisp'."
       (length (feature-parameters feature))))
    (#+:allegro progn
     #+:sbcl with-alien #+:sbcl ((foo (array int 2)))
      (loop
          for i from 0 to (- (length (feature-parameters feature)) 1)
          do (setf
               #+:allegro (fslot-value-typed '(:array :int 2) :c foo i)
               #+:sbcl (deref foo i)
               (nth i (feature-parameters feature))))
      (let ((status
             (db_write_feature
              (fc-db fc) iid rid (feature-tid feature)
              foo (length (feature-parameters feature))
              (feature-code feature) (feature-count feature))))
        (unless (zerop status)
          (error
           "store-feature(): error writing (~a) [~a (~{~a~^ ~})] for ~a@~a."
           (feature-code feature) (feature-tid feature)
           (feature-parameters feature) iid rid))
        (when (zerop (mod (incf (fc-strikes fc)) 5000))
          #+:null
          (db_flush (fc-db fc)))
        status))))

#+:allegro
(def-foreign-call db_read_feature_int
    ((handle :int integer) (chandle :int integer)
     (iid :int integer) (rid :int integer) (tid :int integer)
     (parameters :int integer) (nparameters :int integer)
     (code :int integer) (count :int integer))
  :returning :int)

#+:sbcl
(define-alien-routine ("db_read_feature_int" db_read_feature_int) int
  (handle int) (chandle int)
  (iid int) (rid int) (tid int)
  (parameters (array int nil)) (nparameters int)
  ;; converted by FFI from args to multiple values
  (code int :out) (count int :out)) 

#+:allegro
(def-foreign-call db_read_feature_float
    ((handle :int integer) (chandle :int integer)
     (iid :int integer) (rid :int integer) (tid :int integer)
     (parameters :int integer) (nparameters :int integer)
     (code :int integer) (count :int integer))
  :returning :int)

#+:sbcl
(define-alien-routine ("db_read_feature_float" db_read_feature_float) int
  (handle int) (chandle int)
  (iid int) (rid int) (tid int)
  (parameters (array int nil)) (nparameters int)
  (code int :out) (count single-float :out))

#+:allegro
(defun db_read_feature (db cursor iid rid tid
                        parameters nparameters code count)
  (declare (special *feature-float-valued-tids*))
  (if (member tid *feature-float-valued-tids* :test #'=)
    (db_read_feature_float
     db cursor iid rid tid parameters nparameters code count)
    (db_read_feature_int
     db cursor iid rid tid parameters nparameters code count)))

#+:sbcl
(defun db_read_feature (db cursor iid rid tid
                        parameters nparameters)
  (declare (special *feature-float-valued-tids*))
  (if (member tid *feature-float-valued-tids* :test #'=)
    (db_read_feature_float
     db cursor iid rid tid parameters nparameters)
    (db_read_feature_int
     db cursor iid rid tid parameters nparameters)))

#+:allegro
(let* ((code (allocate-fobject :int :c))
       (icount (allocate-fobject :int :c))
       (fcount (allocate-fobject :float :c))
       (foo (allocate-fobject '(:array :int 2) :c)))

  (defun retrieve-features (fc iid rid tid parameters)
    ;;
    ;; _fix_me_
    ;; on the surface at least, this code appears not thread safe: it probably
    ;; should wrap a process lock around the whole function.    (29-feb-09; oe)
    ;;
    (declare (special *feature-float-valued-tids*))
    (unless (numberp (fc-db fc))
      (error "retrieve-features(): invalid feature cache handle."))
    (when (> (length parameters) 2)
      (error
       "retrieve-features(): excessive parameter list (~a); see `bdb.lisp'."
       (length parameters)))
    (loop
        for i from 0 to (- (length parameters) 1)
        do (setf (fslot-value-typed '(:array :int 2) :c foo i)
             (nth i parameters)))
    (let* ((count (if (member tid *feature-float-valued-tids* :test #'=)
                    fcount
                    icount))
           (type (if (member tid *feature-float-valued-tids* :test #'=)
                   :float
                   :int))
           (cursor
            (db_read_feature
             (fc-db fc) -1 iid rid tid foo (length parameters) code count))
           features)
      (when (>= cursor 0)
        (push
         (make-feature
          :tid tid :parameters parameters
          :code (fslot-value-typed :int :c code)
          :count (fslot-value-typed type :c count))
         features)
        (loop
            for status
            = (db_read_feature
               -1 cursor iid rid tid foo (length parameters) code count)
            while (>= status 0)
            do
              (push
               (make-feature
                :tid tid :parameters parameters
                :code (fslot-value-typed :int :c code)
                :count (fslot-value-typed type :c count))
               features))
        (db_cursor_close cursor))
      features)))

#+:sbcl
(defun retrieve-features (fc iid rid tid parameters)
  ;;
  ;; _fix_me_ as above
  ;;
  (declare (special *feature-float-valued-tids*))
  (unless (numberp (fc-db fc))
    (error "retrieve-features(): invalid feature cache handle."))
  (when (> (length parameters) 2)
    (error
     "retrieve-features(): excessive parameter list (~a); see `bdb.lisp'."
     (length parameters)))
  (with-alien ((foo (array int 2)))
    (loop
        for i from 0 to (- (length parameters) 1)
        do (setf (deref foo i)
             (nth i parameters)))
    (let ((features nil)
          cursor code count)
      (multiple-value-setq (cursor code count)
        (db_read_feature
          (fc-db fc) -1 iid rid tid foo (length parameters)))
      (when (>= cursor 0)
        (push
          (make-feature :tid tid :parameters parameters :code code :count count)
          features)
        (loop
            for status
            = (multiple-value-setq (status code count)
                (db_read_feature
                  -1 cursor iid rid tid foo (length parameters)))
            while (>= status 0)
            do
              (push
	       (make-feature
		:tid tid :parameters parameters :code code :count count)
	       features))
        (db_cursor_close cursor))
      features)))