;;;; -*- coding:utf-8 -*- ;;;;**************************************************************************** ;;;;FILE: raw-memory.lisp ;;;;LANGUAGE: Common-Lisp ;;;;SYSTEM: Common-Lisp ;;;;USER-INTERFACE: NONE ;;;;DESCRIPTION ;;;; ;;;; Peek and Poke. ;;;; ;;;;AUTHORS ;;;; Pascal J. Bourguignon ;;;;MODIFICATIONS ;;;; 2004-11-30 Created. ;;;;BUGS ;;;;LEGAL ;;;; GPL ;;;; ;;;; Copyright Pascal J. Bourguignon 2004 - 2004 ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU General Public License ;;;; as published by the Free Software Foundation; either version ;;;; 2 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 General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU General Public ;;;; License along with this program; if not, write to the Free ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; Boston, MA 02111-1307 USA ;;;;**************************************************************************** ;; (in-package "COMMON-LISP-USER") ;; (eval-when (:compile-toplevel :load-toplevel :execute) ;; (unless (find-package "LINUX") ;; (warn "Package LINUX is not available. Signal handling is disabled.") ;; (defpackage "LINUX" ;; (:use "COMMON-LISP") ;; (:export "set-signal-handler" "sigaddset" "sigemptyset" ;; "sigprocmask-set-n-save" "SIG_UNBLOCK" "SIGSEGV")) ;; (in-package "LINUX") ;; (defmacro null-op (name) ;; `(defmacro ,name (&rest args) (declare (ignore args)) nil)) ;; (eval-when (:compile-toplevel :load-toplevel :execute) ;; (null-op |set-signal-handler|) ;; (null-op |sigaddset|) ;; (null-op |sigemptyset|) ;; (null-op |sigprocmask-set-n-save|) ;; (defparameter |SIG_UNBLOCK| 0) ;; (defparameter |SIGSEGV| 0)))) ;; ;; (in-package "COMMON-LISP-USER") (DEFINE-PACKAGE "COM.INFORMATIMAGO.CLISP.RAW-MEMORY" (:NICKNAMES "RAW-MEMORY") (:DOCUMENTATION "Peek and Poke.") (:FROM "COMMON-LISP" :IMPORT :ALL) (:use "FFI") (:use "LINUX") (:EXPORT "PEEK" "POKE" "DUMP" "WITH-SIGSEG-HANDLER" ;; The following are low-level function, not protected by signal handler. ;; Install you own! "PEEK-UINT8" "PEEK-SINT8" "POKE-UINT8" "POKE-SINT8" "PEEK-UINT16" "PEEK-SINT16" "POKE-UINT16" "POKE-SINT16" "PEEK-UINT32" "PEEK-SINT32" "POKE-UINT32" "POKE-SINT32" "PEEK-UINT64" "PEEK-SINT64" "POKE-UINT64" "POKE-SINT64" )) ;;COM.INFORMATIMAGO.CLISP.RAW-MEMORY (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter +library+ (loop for path in '("libraw-memory.so" "packages:com;informatimago;clisp;libraw-memory.so") until (probe-file path) finally (return (namestring (truename path)))))) (defun install-signal-handler (signum handler) (let ((oldhan (linux:|set-signal-handler| signum handler)) (sigset (second (multiple-value-list (linux:|sigaddset| (second (multiple-value-list (linux:|sigemptyset|))) signum))))) (linux:|sigprocmask-set-n-save| linux:|SIG_UNBLOCK| sigset) (values signum oldhan sigset))) (defun restore-signal-handler (signum oldhan sigset) (linux:|set-signal-handler| signum oldhan) (linux:|sigprocmask-set-n-save| linux:|SIG_UNBLOCK| sigset)) (defmacro with-signal-handler (signum handler &body body) (let ((voldhan (gensym)) (vsignum (gensym)) (vsigset (gensym))) `(let* ((,vsignum ,signum) (,voldhan (linux:|set-signal-handler| ,vsignum ,handler)) (,vsigset (second (multiple-value-list (linux:|sigaddset| (second (multiple-value-list (linux:|sigemptyset|))) ,vsignum))))) (linux:|sigprocmask-set-n-save| linux:|SIG_UNBLOCK| ,vsigset) (unwind-protect (progn ,@body) (linux:|set-signal-handler| ,vsignum ,voldhan) (linux:|sigprocmask-set-n-save| linux:|SIG_UNBLOCK| ,vsigset))))) (defmacro with-sigseg-handler (&body body) `(with-signal-handler linux:|SIGSEGV| (lambda (signum) (declare (ignore signum)) (error "Got Segment Violation Signal while accessing raw memory")) ,@body)) ;; Scalar: (defmacro generate-peek-and-poke () (loop with code = '() for size in '(8 16 32) ;; peek and poke of 64-bit don't work. for c-peek-name = (format nil "peek~D" size) for c-poke-name = (format nil "poke~D" size) do (loop for type in '(uint sint) for l-peek-name = (intern (with-standard-io-syntax (format nil"PEEK-~A~D" type size)) "COM.INFORMATIMAGO.CLISP.RAW-MEMORY") for l-poke-name = (intern (with-standard-io-syntax (format nil"POKE-~A~D" type size)) "COM.INFORMATIMAGO.CLISP.RAW-MEMORY") for l-type = (intern (with-standard-io-syntax (format nil"~A~D" type size)) "FFI") do (push `(ffi:def-call-out ,l-peek-name (:name ,c-peek-name) (:arguments (address ffi:ulong)) (:return-type ,l-type) (:library #.+library+) (:language :stdc)) code) (push `(ffi:def-call-out ,l-poke-name (:name ,c-poke-name) (:arguments (address ffi:ulong) (value ,l-type)) (:return-type nil) (:library #.+library+) (:language :stdc)) code)) finally (return `(progn ,@ code)))) (eval-when (:load-toplevel :execute) (generate-peek-and-poke)) (defun peek-uint64 (address) (dpb (raw-memory:peek-uint32 (+ 4 address)) (byte 32 32) (raw-memory:peek-uint32 address))) (defun peek-sint64 (address) (dpb (raw-memory:peek-uint32 (+ 4 address)) (byte 32 32) (raw-memory:peek-uint32 address))) (defun poke-uint64 (address object) (poke-uint32 address (ldb (byte 32 0) object)) (poke-uint32 (+ 4 address) (ldb (byte 32 32) object))) (defun poke-sint64 (address object) (poke-uint32 address (ldb (byte 32 0) object)) (poke-uint32 (+ 4 address) (ldb (byte 32 32) object))) (defun get-function (type peek-or-poke) (case peek-or-poke ((:peek) (when (atom type) (error "Can't peek this type ~S" type)) (case (first type) ((unsigned-byte) (case (second type) ((8) (values (function peek-uint8 ) 1)) ((16) (values (function peek-uint16) 2)) ((32) (values (function peek-uint32) 4)) ((64) (values (function peek-uint64) 8)) (otherwise (error "Can't peek this type ~S" type)))) ((signed-byte) (case (second type) ((8) (values (function peek-sint8 ) 1)) ((16) (values (function peek-sint16) 2)) ((32) (values (function peek-sint32) 4)) ((64) (values (function peek-sint64) 8)) (otherwise (error "Can't peek this type ~S" type)))) (otherwise (error "Can't peek this type ~S" type)))) ((:poke) (when (atom type) (error "Can't poke this type ~S" type)) (case (first type) ((unsigned-byte) (case (second type) ((8) (values (function poke-uint8 ) 1)) ((16) (values (function poke-uint16) 2)) ((32) (values (function poke-uint32) 4)) ((64) (values (function poke-uint64) 8)) (otherwise (error "Can't poke this type ~S" type)))) ((signed-byte) (case (second type) ((8) (values (function poke-sint8 ) 1)) ((16) (values (function poke-sint16) 2)) ((32) (values (function poke-sint32) 4)) ((64) (values (function poke-sint64) 8)) (otherwise (error "Can't poke this type ~S" type)))) (otherwise (error "Can't poke this type ~S" type)))) (otherwise (error "PEEK-OR-POKE must be either :PEEK or :POKE, not ~S" peek-or-poke)))) ;; type: simtype | comtype. ;; simtype: ;; (unsigned-byte 8) ;; (signed-byte 8) ;; (unsigned-byte 16) ;; (signed-byte 16) ;; (unsigned-byte 32) ;; (signed-byte 32) ;; (unsigned-byte 64) ;; (signed-byte 64) ;; single-float ; not implemented yet. ;; double-float ; not implemented yet. ;; comtype: ;; (array simtype size) ;; (vector simtype size) (defun peek (address type) (with-signal-handler linux:|SIGSEGV| (lambda (signum) (declare (ignore signum)) (error "Got Segment Violation Signal while peeking ~8,'0X" address)) (if (and (listp type) (or (eq (first type) 'array) (eq (first type) 'vector))) (multiple-value-bind (peek incr) (get-function (second type) :peek) (do ((data (make-array (list (third type)) :element-type (second type) :initial-element 0)) (address address (+ address incr)) (i 0 (1+ i))) ((>= i (third type)) data) (setf (aref data i) (funcall peek address)))) (funcall (get-function type :peek) address)))) ;;peek (defun poke (address type value) (with-signal-handler linux:|SIGSEGV| (lambda (signum) (declare (ignore signum)) (error "Got Segment Violation Signal while poking ~8,'0X" address)) (if (and (listp type) (or (eq (first type) 'array) (eq (first type) 'vector))) (multiple-value-bind (poke incr) (get-function (second type) :poke) (do ((address address (+ address incr)) (i 0 (1+ i))) ((>= i (third type)) (values)) (funcall poke address (aref value i)))) (funcall (get-function type :poke) address value)))) ;;poke (defun dump (address type &optional (stream t) (margin "")) (with-signal-handler linux:|SIGSEGV| (lambda (signum) (declare (ignore signum)) (error "Got Segment Violation Signal while peeking ~8,'0X" address)) (if (and (listp type) (or (eq (first type) 'array) (eq (first type) 'vector))) (multiple-value-bind (peek incr) (get-function (second type) :peek) (do ((address address (+ address incr)) (i 0 (1+ i))) ((>= i (third type)) (format stream "~&") (values)) (when (zerop (mod i (/ 16 incr))) (format stream "~&~A~8,'0X: " margin (+ address i))) (format stream "~V,'0X " (* 2 incr) (funcall peek address)))) (multiple-value-bind (peek incr) (get-function type :peek) (format stream "~&~A~8,'0X: ~V,'0X ~&" margin address (* 2 incr) (funcall peek address)))))) ;; Local Variables: ;; eval: (cl-indent 'with-signal-handler 2) ;; End: ;;;; raw-memory.lisp -- -- ;;;;