;;; -*- Log: C.Log; Package: C -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
  "$Header: /project/cmucl/cvsroot/src/compiler/saptran.lisp,v 1.19 2010-03-19 15:19:01 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
;;; This file contains some magic hacks for optimizing SAP operations.
;;;
;;; Written by William Lott.
;;;
(in-package "C")
(intl:textdomain "cmucl")



;;;; Defknowns

    
(defknown foreign-symbol-address (simple-string &key (:flavor t))
  system-area-pointer
  (movable flushable))

(defknown foreign-symbol-code-address (simple-string) system-area-pointer
  (movable flushable))

(defknown foreign-symbol-data-address (simple-string) system-area-pointer
  (movable flushable))

;;; Preserve compatibility for ports that don't use linkage table yet
(deftransform foreign-symbol-address ((symbol &key flavor)
				      (simple-string &rest *))
  #-linkage-table
  (when (null flavor)
    (give-up))
  #+linkage-table
  (unless (constant-continuation-p symbol)
    (give-up))
  (let ((flav (cond ((null flavor) :code)
                    ((not (constant-continuation-p flavor))
		     (give-up))
		    (t (continuation-value flavor)))))
    (case flav
      (:code
       `(#+linkage-table foreign-symbol-code-address
	 #-linkage-table foreign-symbol-address
	 symbol))
      (:data
       `(#+linkage-table foreign-symbol-data-address
	 #-linkage-table foreign-symbol-address
	 symbol))
      (t
       (compiler-error
        _N"FOREIGN-SYMBOL-ADDRESS flavor ~S is not :CODE or :DATA" flav)))))

(defknown (sap< sap<= sap= sap>= sap>)
	  (system-area-pointer system-area-pointer) boolean
  (movable flushable))

(defknown sap+ (system-area-pointer integer) system-area-pointer
  (movable flushable))
(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32)
  (movable flushable))

(defknown sap-int (system-area-pointer) (unsigned-byte #-alpha 32 #+alpha 64)
  (movable flushable))
(defknown int-sap ((unsigned-byte #-alpha 32 #+alpha 64))
  system-area-pointer (movable))


(defknown sap-ref-8 (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64))
  (unsigned-byte 8)
  (flushable))
(defknown %set-sap-ref-8 (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64)
					      (unsigned-byte 8))
  (unsigned-byte 8)
  ())

(defknown sap-ref-16 (system-area-pointer (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63))
  (unsigned-byte 16)
  (flushable))
(defknown %set-sap-ref-16 (system-area-pointer (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63)
					       (unsigned-byte 16))
  (unsigned-byte 16)
  ())

(defknown sap-ref-32 (system-area-pointer fixnum) (unsigned-byte 32)
  (flushable))
(defknown %set-sap-ref-32 (system-area-pointer fixnum (unsigned-byte 32))
  (unsigned-byte 32)
  ())

(defknown sap-ref-64 (system-area-pointer fixnum) (unsigned-byte 64)
  (flushable))
(defknown %set-sap-ref-64 (system-area-pointer fixnum (unsigned-byte 64))
  (unsigned-byte 64)
  ())


(defknown signed-sap-ref-8 (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64))
  (signed-byte 8)
  (flushable))
(defknown %set-signed-sap-ref-8 (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64)
						     (signed-byte 8))
  (signed-byte 8)
  ())

(defknown signed-sap-ref-16 (system-area-pointer (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63))
  (signed-byte 16)
  (flushable))
(defknown %set-signed-sap-ref-16 (system-area-pointer (signed-byte #-alpha #.(1- vm:word-bits) #+alpha 63)
						      (signed-byte 16))
  (signed-byte 16)
  ())

(defknown signed-sap-ref-32 (system-area-pointer fixnum) (signed-byte 32)
  (flushable))
(defknown %set-signed-sap-ref-32 (system-area-pointer fixnum (signed-byte 32))
  (signed-byte 32)
  ())

(defknown signed-sap-ref-64 (system-area-pointer fixnum) (signed-byte 64)
  (flushable))
(defknown %set-signed-sap-ref-64 (system-area-pointer fixnum (signed-byte 64))
  (signed-byte 64)
  ())


(defknown sap-ref-sap (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64))
  system-area-pointer
  (flushable))
(defknown %set-sap-ref-sap (system-area-pointer (signed-byte #-alpha #.vm:word-bits #+alpha 64)
						system-area-pointer)
  system-area-pointer
  ())

(defknown sap-ref-single (system-area-pointer fixnum) single-float
  (flushable))
(defknown sap-ref-double (system-area-pointer fixnum) double-float
  (flushable))
#+(or x86 amd64 long-float)
(defknown sap-ref-long (system-area-pointer fixnum) long-float
  (flushable))

(defknown %set-sap-ref-single
	  (system-area-pointer fixnum single-float) single-float
  ())
(defknown %set-sap-ref-double
	  (system-area-pointer fixnum double-float) double-float
  ())
#+(or x86 long-float)
(defknown %set-sap-ref-long
	  (system-area-pointer fixnum long-float) long-float
  ())


;;;; Transforms for converting sap relation operators.

(dolist (info '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >)))
  (destructuring-bind (sap-fun int-fun) info
    (deftransform sap-fun ((x y) '* '* :eval-name t)
      `(,int-fun (sap-int x) (sap-int y)))))


;;;; Transforms for optimizing sap+

(deftransform sap+ ((sap offset))
  (cond ((and (constant-continuation-p offset)
	      (eql (continuation-value offset) 0))
	 'sap)
	(t
	 (extract-function-args sap 'sap+ 2)
	 '(lambda (sap offset1 offset2)
	    (sap+ sap (+ offset1 offset2))))))

(dolist (fun '(sap-ref-8 %set-sap-ref-8
	       signed-sap-ref-8 %set-signed-sap-ref-8
	       sap-ref-16 %set-sap-ref-16
	       signed-sap-ref-16 %set-signed-sap-ref-16
	       sap-ref-32 %set-sap-ref-32
	       signed-sap-ref-32 %set-signed-sap-ref-32
	       sap-ref-64 %set-sap-ref-64
	       signed-sap-ref-64 %set-signed-sap-ref-64
	       sap-ref-sap %set-sap-ref-sap
	       sap-ref-single %set-sap-ref-single
	       sap-ref-double %set-sap-ref-double
	       #+(or x86 long-float) sap-ref-long
	       #+long-float %set-sap-ref-long))
  (deftransform fun ((sap offset) '* '* :eval-name t)
    (extract-function-args sap 'sap+ 2)
    `(lambda (sap offset1 offset2)
       (,fun sap (+ offset1 offset2)))))
