lolevel.scm

Scheme跨平台编译器

;;;; lolevel.scm - Low-level routines for CHICKEN
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   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. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS 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.


(declare
  (unit lolevel)
  (usual-integrations)
  (disable-warning var redef)
  (hide ipc-hook-0 xproc-tag)
  (foreign-declare #<<EOF
#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
# include <sys/types.h>
#endif
#ifndef C_NONUNIX
# include <sys/mman.h>
#endif

#define C_pointer_to_object(ptr)   ((C_word*)C_block_item(ptr, 0))
#define C_w2b(x)                   C_fix(C_wordstobytes(C_unfix(x)))
#define C_pointer_eqp(x, y)        C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
EOF
) )

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure
     ##sys#hash-table-ref ##sys#hash-table-set!
     ##sys#make-locative ##sys#become!
     ##sys#make-string
     make-property-condition make-composite-condition signal ##sys#set-pointer-address! ##sys#make-vector
     ##sys#make-pointer make-string make-byte-vector ##sys#not-a-proper-list-error ##sys#check-pointer
     ##sys#locative? ##sys#bytevector?
     extend-procedure ##sys#lambda-decoration ##sys#decorate-lambda ##sys#make-tagged-pointer ##sys#check-special
     ##sys#vector->closure! ##sys#error ##sys#signal-hook ##sys#address->pointer ##sys#pointer->address) ) ] )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-range . _) '(##core#undefined))
    (define-macro (##sys#check-pair . _) '(##core#undefined))
    (define-macro (##sys#check-list . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-char . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined))
    (define-macro (##sys#check-port . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-pointer . _) '(##core#undefined))
    (define-macro (##sys#check-special . _) '(##core#undefined))
    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
 [else
  (declare (emit-exports "lolevel.exports"))] )

(register-feature! 'lolevel)


;;; Move arbitrary blocks of memory around:

(define move-memory!
  (let ([memmove1 (foreign-lambda void "C_memmove_o" c-pointer c-pointer int int int)]
	[memmove2 (foreign-lambda void "C_memmove_o" c-pointer scheme-pointer int int int)]
	[memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
	[memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
	[slot1structs '(mmap u8vector u16vector u32vector s8vector s16vector s32vector f32vector f64vector)] )
    (lambda (from to #!optional n (foffset 0) (toffset 0))
      (define (err) (##sys#error 'move-memory! "need number of bytes to move" from to))
      (define (xerr x) (##sys#signal-hook #:type-error 'move-memory! "invalid argument type" x))
      (define (checkn n nmax off)
	(if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
	    n
	    (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax) ) )
      (define (checkn2 n nmax nmax2 off1 off2)
	(if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
	    n
	    (##sys#error 'move-memory! "number of bytes to move too large" from to n nmax nmax2) ) )
      (let move ([from from] [to to])
	(cond [(##sys#generic-structure? from)
	       (if (memq (##sys#slot from 0) slot1structs)
		   (move (##sys#slot from 1) to)
		   (xerr from) ) ]
	      [(##sys#generic-structure? to)
	       (if (memq (##sys#slot to 0) slot1structs)
		   (move from (##sys#slot to 1))
		   (xerr to) ) ]
	      [(or (##sys#pointer? from) (##sys#locative? from))
	       (cond [(or (##sys#pointer? to) (##sys#locative? to))
		      (memmove1 to from (or n (err)) toffset foffset)]
		     [(or (##sys#bytevector? to) (string? to))
		      (memmove3 to from (checkn (or n (err)) (##sys#size to) toffset) toffset foffset) ]
		     [else (xerr to)] ) ]
	      [(or (##sys#bytevector? from) (string? from))
	       (let ([nfrom (##sys#size from)])
		 (cond [(or (##sys#pointer? to) (##sys#locative? to))
			(memmove2 to from (checkn (or n nfrom) nfrom foffset) toffset foffset)]
		       [(or (##sys#bytevector? to) (string? to))
			(memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
				  toffset foffset) ]
		       [else (xerr to)] ) ) ]
	      [else (xerr from)] ) ) ) ) )


;;; Pointer operations:

(define (##sys#check-pointer ptr loc)
  (unless (and (##core#inline "C_blockp" ptr)
	       (or (##core#inline "C_pointerp" ptr)
		   (##core#inline "C_swigpointerp" ptr)
		   (##core#inline "C_taggedpointerp" ptr) ) )
    (##sys#signal-hook #:type-error loc "bad argument type - not a pointer" ptr) ) )

(define null-pointer ##sys#null-pointer)

(define (pointer? x)
  (and (##core#inline "C_blockp" x)
       (or (##core#inline "C_pointerp" x)
	   (##core#inline "C_taggedpointerp" x) ) ) )

(define (address->pointer addr)
  (cond-expand
   [(not unsafe)
    (when (not (integer? addr))
      (##sys#signal-hook #:type-error 'address->pointer "bad argument type - not an integer" addr) ) ]
   [else] )
  (##sys#address->pointer addr) )

(define (pointer->address ptr)
  (##sys#check-special ptr 'pointer->address)
  (##sys#pointer->address ptr) )

(define (null-pointer? ptr)
  (##sys#check-special ptr 'null-pointer?)
  (eq? 0 (##sys#pointer->address ptr) ) )

(define (object->pointer x)
  (and (##core#inline "C_blockp" x)
       ((foreign-lambda* nonnull-c-pointer ((scheme-object x))
	  "return((void *)x);") 
	x) ) )

(define (pointer->object ptr)
  (##sys#check-pointer ptr 'pointer->object)
  (##core#inline "C_pointer_to_object" ptr) )

(define (pointer=? p1 p2)
  (##sys#check-special p1 'pointer=?)
  (##sys#check-special p2 'pointer=?)
  (##core#inline "C_pointer_eqp" p1 p2) )

(define allocate (foreign-lambda c-pointer "C_malloc" int))
(define free (foreign-lambda void "C_free" c-pointer))

(define align-to-word
  (let ([align (foreign-lambda integer "C_align" integer)])
    (lambda (x)
      (cond [(number? x) (align x)]
	    [(and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
	     (##sys#address->pointer (align (##sys#pointer->address x))) ]
	    [else (##sys#signal-hook #:type-error 'align-to-word "bad argument type - not a pointer or fixnum" x)] ) ) ) )

(define pointer-offset
  (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
    "return((unsigned char *)ptr + off);") )

(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
(define pointer-u16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned short *)p) = n;"))
(define pointer-s16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((short *)p) = n;"))
(define pointer-u32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_u32 *)p) = n;"))
(define pointer-s32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_s32 *)p) = n;"))
(define pointer-f32-set! (foreign-lambda* void ([c-pointer p] [double n]) "*((float *)p) = n;"))
(define pointer-f64-set! (foreign-lambda* void ([c-pointer p] [float n]) "*((double *)p) = n;"))

(define pointer-u8-ref
  (getter-with-setter
   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned char *)p));")
   pointer-u8-set!) )

(define pointer-s8-ref
  (getter-with-setter
   (foreign-lambda* int ([c-pointer p]) "return(*((char *)p));")
   pointer-s8-set!) )

(define pointer-u16-ref
  (getter-with-setter
   (foreign-lambda* int ([c-pointer p]) "return(*((unsigned short *)p));")
   pointer-u16-set!) )

(define pointer-s16-ref
  (getter-with-setter
   (foreign-lambda* int ([c-pointer p]) "return(*((short *)p));")
   pointer-s6-set!) )

(define pointer-u32-ref
  (getter-with-setter
   (foreign-lambda* integer ([c-pointer p]) "return(*((C_u32 *)p));")
   pointer-u32-set!) )

(define pointer-s32-ref
  (getter-with-setter
   (foreign-lambda* integer ([c-pointer p]) "return(*((C_s32 *)p));")
   pointer-s32-set!) )

(define pointer-f32-ref
  (getter-with-setter
   (foreign-lambda* float ([c-pointer p]) "return(*((float *)p));")
   pointer-f32-set!) )

(define pointer-f64-ref
  (getter-with-setter
   (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
   pointer-f64-set!) )

(define (tag-pointer ptr tag)
  (let ([tp (##sys#make-tagged-pointer tag)])
    (if (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
	(##core#inline "C_copy_pointer" ptr tp)
	(##sys#signal-hook #:type-error 'tag-pointer "bad argument type - not a pointer" ptr) )
    tp) )

(define (tagged-pointer? x tag)
  (and (##core#inline "C_blockp" x) 
       (##core#inline "C_taggedpointerp" x)
       (equal? tag (##sys#slot x 1)) ) )

(define (pointer-tag x)
  (if (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x))
      (and (##core#inline "C_taggedpointerp" x)
	   (##sys#slot x 1) )
      (##sys#signal-hook #:type-error 'pointer-tag "bad argument type - not a pointer" x) ) )


;;; Procedures extended with data:

(define xproc-tag (vector 'extended))

(define (extend-procedure proc data)
  #+(not unsafe)
  (unless (##core#inline "C_closurep" proc)
    (##sys#signal-hook #:type-error 'extend-procedure "bad argument type - not a procedure" proc) )
  (##sys#decorate-lambda
   proc
   (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))) 
   (lambda (x i)
     (##sys#setslot x i (cons xproc-tag data))
     x) ) )

(define (extended-procedure? x)
  (and (##core#inline "C_blockp" x)
       (##core#inline "C_closurep" x)
       (##sys#lambda-decoration x (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))))
       #t) )

(define (procedure-data x)
  (and (##core#inline "C_blockp" x)
       (##core#inline "C_closurep" x)
       (and-let* ((d (##sys#lambda-decoration x (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0)))))))
	 (##sys#slot d 1) ) ) )

(define set-procedure-data!
  (let ((extend-procedure extend-procedure))
    (lambda (proc x)
      (let ((p2 (extend-procedure proc x)))
	(if (eq? p2 proc)
	    proc
	    (##sys#signal-hook #:type-error 'set-procedure-data! "bad argument type - not an extended procedure" proc) ) ) ) ) )


;;; Bytevector stuff:

(define byte-vector? blob?)		; DEPRECATED

(define (byte-vector-fill! bv n)	; DEPRECATED
  (##sys#check-byte-vector bv 'byte-vector-fill!)
  (##sys#check-exact n 'byte-vector-fill!)
  (let ([len (##sys#size bv)])
    (do ([i 0 (fx+ i 1)])
	((fx>= i len))
      (##sys#setbyte bv i n) ) ) )

(define make-byte-vector		; DEPRECATED
    (lambda (size . init)
      (let ([bv (make-blob size)])
	(when (pair? init) (byte-vector-fill! bv (car init)))
	bv) ) )

(define byte-vector			; DEPRECATED
    (lambda bytes
      (let* ([n (length bytes)]
	     [bv (make-byte-vector n)] )
	(do ([i 0 (fx+ i 1)]
	     [bytes bytes (##sys#slot bytes 1)] )
	    ((fx>= i n) bv)
	  (##sys#setbyte bv i (##sys#slot bytes 0)) ) ) ) )

(define byte-vector-set!		; DEPRECATED
  (lambda (bv i x)
    (##sys#check-byte-vector bv 'byte-vector-set!)
    (##sys#check-exact i 'byte-vector-set!)
    (##sys#check-exact x 'byte-vector-set!)
    (let ([n (##sys#size bv)])
      (if (or (fx< i 0) (fx>= i n))
	  (##sys#error 'byte-vector-set! "out of range" bv i)
	  (##sys#setbyte bv i x) ) ) ) )

(define byte-vector-ref			; DEPRECATED
  (getter-with-setter
   (lambda (bv i)
     (##sys#check-byte-vector bv 'byte-vector-ref)
     (##sys#check-exact i 'byte-vector-ref)
     (let ([n (##sys#size bv)])
       (if (or (fx< i 0) (fx>= i n))
	   (##sys#error 'byte-vector-ref "out of range" bv i)
	   (##sys#byte bv i) ) ) )
   byte-vector-set!) )

(define (byte-vector->list bv)		; DEPRECATED
  (##sys#check-byte-vector bv 'byte-vector->list)
  (let ([len (##sys#size bv)])
    (let loop ([i 0])
      (if (fx>= i len)
	  '()
	  (cons (##sys#byte bv i) 
		(loop (fx+ i 1)) ) ) ) ) )