X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsaptran.lisp;h=f709ceabb939765169e5ff9c69c32dd7d09bdeb8;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=4719183a4ff38a708076bbb008090155b49157b5;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp index 4719183..f709cea 100644 --- a/src/compiler/saptran.lisp +++ b/src/compiler/saptran.lisp @@ -10,14 +10,32 @@ ;;;; files for more information. (in-package "SB!C") - -(file-comment - "$Header$") ;;;; DEFKNOWNs -(defknown foreign-symbol-address (simple-string) system-area-pointer - (movable flushable)) +#!+linkage-table +(deftransform foreign-symbol-address-as-integer ((symbol &optional datap) + (simple-string boolean)) + (if (and (constant-lvar-p symbol) (constant-lvar-p datap)) + `(sap-int (foreign-symbol-address symbol datap)) + (give-up-ir1-transform))) + +(deftransform foreign-symbol-address ((symbol &optional datap) + (simple-string &optional boolean)) + #!-linkage-table + (if (null datap) + (give-up-ir1-transform) + `(foreign-symbol-address symbol)) + #!+linkage-table + (if (and (constant-lvar-p symbol) (constant-lvar-p datap)) + (let ((name (lvar-value symbol)) + (datap (lvar-value datap))) + (if (or #+sb-xc-host t ; only static symbols on host + (not datap) + (find-foreign-symbol-in-table name *static-foreign-symbols*)) + `(foreign-symbol-address ,name) ; VOP + `(foreign-symbol-dataref-address ,name))) ; VOP + (give-up-ir1-transform))) (defknown (sap< sap<= sap= sap>= sap>) (system-area-pointer system-area-pointer) boolean @@ -25,12 +43,14 @@ (defknown sap+ (system-area-pointer integer) system-area-pointer (movable flushable)) -(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32) +(defknown sap- (system-area-pointer system-area-pointer) + (signed-byte #.sb!vm::n-word-bits) (movable flushable)) -(defknown sap-int (system-area-pointer) (unsigned-byte #!-alpha 32 #!+alpha 64) +(defknown sap-int (system-area-pointer) + (unsigned-byte #.sb!vm::n-machine-word-bits) (movable flushable)) -(defknown int-sap ((unsigned-byte #!-alpha 32 #!+alpha 64)) +(defknown int-sap ((unsigned-byte #.sb!vm::n-machine-word-bits)) system-area-pointer (movable)) (defknown sap-ref-8 (system-area-pointer fixnum) (unsigned-byte 8) @@ -51,14 +71,23 @@ (unsigned-byte 32) ()) -#!+alpha +;; FIXME These are supported natively on alpha and using deftransforms +;; in compiler/x86/sap.lisp, which in OAO$n$ style need copying to +;; other 32 bit systems (defknown sap-ref-64 (system-area-pointer fixnum) (unsigned-byte 64) (flushable)) -#!+alpha (defknown %set-sap-ref-64 (system-area-pointer fixnum (unsigned-byte 64)) (unsigned-byte 64) ()) +(defknown sap-ref-word (system-area-pointer fixnum) + (unsigned-byte #.sb!vm::n-machine-word-bits) + (flushable)) +(defknown %set-sap-ref-word + (system-area-pointer fixnum (unsigned-byte #.sb!vm::n-machine-word-bits)) + (unsigned-byte #.sb!vm::n-machine-word-bits) + ()) + (defknown signed-sap-ref-8 (system-area-pointer fixnum) (signed-byte 8) (flushable)) (defknown %set-signed-sap-ref-8 (system-area-pointer fixnum (signed-byte 8)) @@ -77,14 +106,20 @@ (signed-byte 32) ()) -#!+alpha (defknown signed-sap-ref-64 (system-area-pointer fixnum) (signed-byte 64) (flushable)) -#!+alpha (defknown %set-signed-sap-ref-64 (system-area-pointer fixnum (signed-byte 64)) (signed-byte 64) ()) +(defknown signed-sap-ref-word (system-area-pointer fixnum) + (signed-byte #.sb!vm::n-machine-word-bits) + (flushable)) +(defknown %set-signed-sap-ref-word + (system-area-pointer fixnum (signed-byte #.sb!vm::n-machine-word-bits)) + (signed-byte #.sb!vm::n-machine-word-bits) + ()) + (defknown sap-ref-sap (system-area-pointer fixnum) system-area-pointer (flushable)) (defknown %set-sap-ref-sap (system-area-pointer fixnum system-area-pointer) @@ -112,34 +147,68 @@ ;;;; 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))))) +(macrolet ((def (sap-fun int-fun) + `(deftransform ,sap-fun ((x y) * *) + `(,',int-fun (sap-int x) (sap-int y))))) + (def sap< <) + (def sap<= <=) + (def sap= =) + (def sap>= >=) + (def sap> >)) ;;;; transforms for optimizing SAP+ (deftransform sap+ ((sap offset)) - (cond ((and (constant-continuation-p offset) - (eql (continuation-value offset) 0)) + (cond ((and (constant-lvar-p offset) + (eql (lvar-value offset) 0)) 'sap) (t - (extract-function-args sap 'sap+ 2) + (extract-fun-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-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))))) +(macrolet ((def (fun) + `(deftransform ,fun ((sap offset) * *) + (extract-fun-args sap 'sap+ 2) + `(lambda (sap offset1 offset2) + (,',fun sap (+ offset1 offset2)))))) + (def sap-ref-8) + (def %set-sap-ref-8) + (def signed-sap-ref-8) + (def %set-signed-sap-ref-8) + (def sap-ref-16) + (def %set-sap-ref-16) + (def signed-sap-ref-16) + (def %set-signed-sap-ref-16) + (def sap-ref-32) + (def %set-sap-ref-32) + (def signed-sap-ref-32) + (def %set-signed-sap-ref-32) + (def sap-ref-64) + (def %set-sap-ref-64) + (def signed-sap-ref-64) + (def %set-signed-sap-ref-64) + (def sap-ref-sap) + (def %set-sap-ref-sap) + (def sap-ref-single) + (def %set-sap-ref-single) + (def sap-ref-double) + (def %set-sap-ref-double) + ;; The original CMUCL code had #!+(and x86 long-float) for this first one, + ;; but only #!+long-float for the second. This was redundant, since the + ;; LONG-FLOAT target feature only exists on X86. So we removed the + ;; redundancy. --njf 2002-01-08 + #!+long-float (def sap-ref-long) + #!+long-float (def %set-sap-ref-long)) + +(macrolet ((def (fun args 32-bit 64-bit) + `(deftransform ,fun (,args) + (ecase sb!vm::n-word-bits + (32 '(,32-bit ,@args)) + (64 '(,64-bit ,@args)))))) + (def sap-ref-word (sap offset) sap-ref-32 sap-ref-64) + (def signed-sap-ref-word (sap offset) signed-sap-ref-32 signed-sap-ref-64) + (def %set-sap-ref-word (sap offset value) + %set-sap-ref-32 %set-sap-ref-64) + (def %set-signed-sap-ref-word (sap offset value) + %set-signed-sap-ref-32 %set-signed-sap-ref-64))