mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-18 23:32:17 -08:00
cmp: cleanup: rename REP-TYPE to HOST-TYPE
The name HOST-TYPE is less ambiguous.
This commit is contained in:
Daniel Kochmański
parent
00f96d34b0
commit
a07b39ad65
17 changed files with 240 additions and 240 deletions
|
|
@ -15,11 +15,11 @@
|
|||
(defstruct (inlined-arg (:constructor %make-inlined-arg))
|
||||
loc
|
||||
type
|
||||
rep-type)
|
||||
host-type)
|
||||
|
||||
(defun make-inlined-arg (loc lisp-type)
|
||||
(%make-inlined-arg :loc loc :type lisp-type
|
||||
:rep-type (loc-representation-type loc)))
|
||||
:host-type (loc-host-type loc)))
|
||||
|
||||
(defun maybe-open-inline-block ()
|
||||
(unless (plusp *inline-blocks*)
|
||||
|
|
@ -49,43 +49,43 @@
|
|||
(loop with block-opened = nil
|
||||
for arg in inlined-args
|
||||
for loc = (inlined-arg-loc arg)
|
||||
for arg-rep-type = (inlined-arg-rep-type arg)
|
||||
for arg-host-type = (inlined-arg-host-type arg)
|
||||
for type in (or types '#1=(:object . #1#))
|
||||
for i from 0
|
||||
for rep-type = (lisp-type->rep-type type)
|
||||
for host-type = (lisp-type->host-type type)
|
||||
collect
|
||||
(cond ((and args-to-be-saved
|
||||
(member i args-to-be-saved :test #'eql)
|
||||
(not (loc-movable-p loc)))
|
||||
(let ((lcl (make-lcl-var :rep-type rep-type)))
|
||||
(let ((lcl (make-lcl-var :host-type host-type)))
|
||||
(wt-nl)
|
||||
(unless block-opened
|
||||
(setf block-opened t)
|
||||
(open-inline-block))
|
||||
(wt (rep-type->c-name rep-type) " " lcl "= ")
|
||||
(wt-coerce-loc rep-type loc)
|
||||
(wt (host-type->c-name host-type) " " lcl "= ")
|
||||
(wt-coerce-loc host-type loc)
|
||||
(wt ";")
|
||||
lcl))
|
||||
((equal rep-type arg-rep-type)
|
||||
((equal host-type arg-host-type)
|
||||
loc)
|
||||
(t
|
||||
`(COERCE-LOC ,rep-type ,loc)))))
|
||||
`(COERCE-LOC ,host-type ,loc)))))
|
||||
|
||||
(defun make-inline-temp-var (value-type &optional rep-type)
|
||||
(let ((out-rep-type (or rep-type (lisp-type->rep-type value-type))))
|
||||
(if (eq out-rep-type :object)
|
||||
(defun make-inline-temp-var (value-type &optional host-type)
|
||||
(let ((out-host-type (or host-type (lisp-type->host-type value-type))))
|
||||
(if (eq out-host-type :object)
|
||||
(make-temp-var value-type)
|
||||
(let ((var (make-lcl-var :rep-type out-rep-type
|
||||
(let ((var (make-lcl-var :host-type out-host-type
|
||||
:type value-type)))
|
||||
(open-inline-block)
|
||||
(wt-nl (rep-type->c-name out-rep-type) " " var ";")
|
||||
(wt-nl (host-type->c-name out-host-type) " " var ";")
|
||||
var))))
|
||||
|
||||
(defun emit-inlined-variable (form rest-forms)
|
||||
(let ((var (c1form-arg 0 form))
|
||||
(lisp-type (c1form-primary-type form)))
|
||||
(if (var-changed-in-form-list var rest-forms)
|
||||
(let ((temp (make-inline-temp-var lisp-type (var-rep-type var))))
|
||||
(let ((temp (make-inline-temp-var lisp-type (var-host-type var))))
|
||||
(set-loc temp var)
|
||||
(make-inlined-arg temp lisp-type))
|
||||
(make-inlined-arg var lisp-type))))
|
||||
|
|
|
|||
|
|
@ -17,8 +17,8 @@
|
|||
|
||||
(defstruct (inline-info)
|
||||
name ;;; Function name
|
||||
arg-rep-types ;;; List of representation types for the arguments
|
||||
return-rep-type ;;; Representation type for the output
|
||||
arg-host-types ;;; List of representation types for the arguments
|
||||
return-host-type ;;; Representation type for the output
|
||||
arg-types ;;; List of lisp types for the arguments
|
||||
return-type ;;; Lisp type for the output
|
||||
exact-return-type ;;; Only use this expansion when the output is
|
||||
|
|
@ -47,33 +47,33 @@
|
|||
;;; locs are typed locs as produced by inline-args
|
||||
;;; returns NIL if inline expansion of the function is not possible
|
||||
;;;
|
||||
(defun inline-function (fname arg-types return-type &optional (return-rep-type 'any))
|
||||
(defun inline-function (fname arg-types return-type &optional (return-host-type 'any))
|
||||
;; Those functions that use INLINE-FUNCTION must rebind the variable
|
||||
;; *INLINE-BLOCKS*.
|
||||
(and (inline-possible fname)
|
||||
(not (gethash fname *c2-dispatch-table*))
|
||||
(let* (;; (dest-rep-type (loc-representation-type *destination*))
|
||||
(ii (get-inline-info fname arg-types return-type return-rep-type)))
|
||||
(let* (;; (dest-host-type (loc-host-type *destination*))
|
||||
(ii (get-inline-info fname arg-types return-type return-host-type)))
|
||||
ii)))
|
||||
|
||||
(defun apply-inline-info (ii inlined-locs)
|
||||
(let* ((arg-types (inline-info-arg-types ii))
|
||||
(out-rep-type (inline-info-return-rep-type ii))
|
||||
(out-host-type (inline-info-return-host-type ii))
|
||||
;; (out-type (inline-info-return-type ii))
|
||||
(side-effects-p (function-may-have-side-effects (inline-info-name ii)))
|
||||
(fun (inline-info-expansion ii))
|
||||
(one-liner (inline-info-one-liner ii)))
|
||||
(produce-inline-loc inlined-locs arg-types (list out-rep-type)
|
||||
(produce-inline-loc inlined-locs arg-types (list out-host-type)
|
||||
fun side-effects-p one-liner)))
|
||||
|
||||
(defun choose-inline-info (ia ib return-type return-rep-type)
|
||||
(defun choose-inline-info (ia ib return-type return-host-type)
|
||||
(declare (ignore return-type))
|
||||
(cond
|
||||
;; Only accept inliners that have the right rep type
|
||||
((not (or (eq return-rep-type 'any)
|
||||
(eq return-rep-type :void)
|
||||
(let ((info-type (inline-info-return-rep-type ib)))
|
||||
(or (eq return-rep-type info-type)
|
||||
((not (or (eq return-host-type 'any)
|
||||
(eq return-host-type :void)
|
||||
(let ((info-type (inline-info-return-host-type ib)))
|
||||
(or (eq return-host-type info-type)
|
||||
;; :bool can be coerced to any other location type
|
||||
(eq info-type :bool)))))
|
||||
ia)
|
||||
|
|
@ -89,16 +89,16 @@
|
|||
(t
|
||||
ia)))
|
||||
|
||||
(defun get-inline-info (fname types return-type return-rep-type)
|
||||
(defun get-inline-info (fname types return-type return-host-type)
|
||||
(declare (si::c-local))
|
||||
(let ((output nil))
|
||||
(unless (safe-compile)
|
||||
(dolist (x (inline-information fname ':INLINE-UNSAFE))
|
||||
(ext:when-let ((other (inline-type-matches x types return-type)))
|
||||
(setf output (choose-inline-info output other return-type return-rep-type)))))
|
||||
(setf output (choose-inline-info output other return-type return-host-type)))))
|
||||
(dolist (x (inline-information fname ':INLINE-ALWAYS))
|
||||
(ext:when-let ((other (inline-type-matches x types return-type)))
|
||||
(setf output (choose-inline-info output other return-type return-rep-type))))
|
||||
(setf output (choose-inline-info output other return-type return-host-type))))
|
||||
output))
|
||||
|
||||
(defun to-fixnum-float-type (type)
|
||||
|
|
@ -150,7 +150,7 @@
|
|||
;; Now there is an optional check of the return type. This check is
|
||||
;; only used when enforced by the inliner.
|
||||
;;
|
||||
(when (or (eq (inline-info-return-rep-type inline-info) :bool)
|
||||
(when (or (eq (inline-info-return-host-type inline-info) :bool)
|
||||
(null (inline-info-exact-return-type inline-info))
|
||||
(and (policy-assume-right-type)
|
||||
(let ((inline-return-type (inline-info-return-type inline-info)))
|
||||
|
|
@ -172,7 +172,7 @@
|
|||
(nreverse rts))
|
||||
inline-info))))
|
||||
|
||||
(defun produce-inline-loc (inlined-arguments arg-types output-rep-type
|
||||
(defun produce-inline-loc (inlined-arguments arg-types output-host-type
|
||||
c-expression side-effects one-liner)
|
||||
(let* (args-to-be-saved
|
||||
coerced-arguments)
|
||||
|
|
@ -193,15 +193,15 @@
|
|||
args-to-be-saved))))
|
||||
|
||||
(setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved))
|
||||
;;(setf output-rep-type (lisp-type->rep-type output-rep-type))
|
||||
;;(setf output-host-type (lisp-type->host-type output-host-type))
|
||||
|
||||
;; If the form does not output any data, and there are no side
|
||||
;; effects, try to omit it.
|
||||
(when (null output-rep-type)
|
||||
(when (null output-host-type)
|
||||
(if side-effects
|
||||
(progn
|
||||
(wt-nl)
|
||||
(wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil)
|
||||
(wt-c-inline-loc output-host-type c-expression coerced-arguments t nil)
|
||||
(when one-liner (wt ";")))
|
||||
(cmpnote "Ignoring form ~S" c-expression))
|
||||
(wt-nl "value0 = ECL_NIL;")
|
||||
|
|
@ -212,25 +212,25 @@
|
|||
;; place where the value is used.
|
||||
(when one-liner
|
||||
(return-from produce-inline-loc
|
||||
`(ffi:c-inline ,output-rep-type ,c-expression ,coerced-arguments ,side-effects
|
||||
,(if (equalp output-rep-type '((VALUES &REST T)))
|
||||
`(ffi:c-inline ,output-host-type ,c-expression ,coerced-arguments ,side-effects
|
||||
,(if (equalp output-host-type '((VALUES &REST T)))
|
||||
'VALUES NIL))))
|
||||
|
||||
;; If the output is a in the VALUES vector, just write down the form and
|
||||
;; output the location of the data.
|
||||
(when (equalp output-rep-type '((VALUES &REST T)))
|
||||
(wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects
|
||||
(when (equalp output-host-type '((VALUES &REST T)))
|
||||
(wt-c-inline-loc output-host-type c-expression coerced-arguments side-effects
|
||||
'VALUES)
|
||||
(return-from produce-inline-loc 'VALUEZ))
|
||||
|
||||
;; Otherwise we have to set up variables for holding the output.
|
||||
(flet ((make-output-var (type)
|
||||
(let ((var (make-lcl-var :rep-type type)))
|
||||
(wt-nl (rep-type->c-name type) " " var ";")
|
||||
(let ((var (make-lcl-var :host-type type)))
|
||||
(wt-nl (host-type->c-name type) " " var ";")
|
||||
var)))
|
||||
(open-inline-block)
|
||||
(let ((output-vars (mapcar #'make-output-var output-rep-type)))
|
||||
(wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars)
|
||||
(let ((output-vars (mapcar #'make-output-var output-host-type)))
|
||||
(wt-c-inline-loc output-host-type c-expression coerced-arguments side-effects output-vars)
|
||||
(cond ((= (length output-vars) 1)
|
||||
(first output-vars))
|
||||
(t
|
||||
|
|
@ -243,15 +243,15 @@
|
|||
;;; Whoever calls this function must wrap the body in WITH-INLINE-BLOCKS.
|
||||
(defun negate-argument (argument dest-loc)
|
||||
(let* ((inlined-arg (emit-inline-form argument nil))
|
||||
(rep-type (inlined-arg-rep-type inlined-arg)))
|
||||
(host-type (inlined-arg-host-type inlined-arg)))
|
||||
(apply #'produce-inline-loc
|
||||
(list inlined-arg)
|
||||
(if (eq (loc-representation-type dest-loc) :bool)
|
||||
(case rep-type
|
||||
(if (eq (loc-host-type dest-loc) :bool)
|
||||
(case host-type
|
||||
(:bool '((:bool) (:bool) "(#0)==ECL_NIL" nil t))
|
||||
(:object '((:object) (:bool) "(#0)!=ECL_NIL" nil t))
|
||||
(otherwise (return-from negate-argument nil)))
|
||||
(case rep-type
|
||||
(case host-type
|
||||
(:bool '((:bool) (:object) "(#0)?ECL_NIL:ECL_T" nil t))
|
||||
(:object '((:object) (:object) "Null(#0)?ECL_T:ECL_NIL" nil t))
|
||||
(otherwise (return-from negate-argument *vv-nil*)))))))
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
;;;
|
||||
;;; DATABASE OF INLINE EXPANSIONS
|
||||
;;;
|
||||
;;; (DEF-INLINE function-name kind ([arg-type]*) return-rep-type
|
||||
;;; (DEF-INLINE function-name kind ([arg-type]*) return-host-type
|
||||
;;; expansion-string)
|
||||
;;;
|
||||
;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family,
|
||||
|
|
@ -52,10 +52,10 @@
|
|||
(defun (setf inline-information) (value name safety)
|
||||
(setf (gethash (list name safety) *inline-information*) value))
|
||||
|
||||
(defun %def-inline (name safety arg-types return-rep-type expansion
|
||||
(defun %def-inline (name safety arg-types return-host-type expansion
|
||||
&key (one-liner t) (exact-return-type nil)
|
||||
(multiple-values t)
|
||||
&aux arg-rep-types)
|
||||
&aux arg-host-types)
|
||||
(setf safety
|
||||
(case safety
|
||||
(:unsafe :inline-unsafe)
|
||||
|
|
@ -64,26 +64,26 @@
|
|||
;; Ensure we can inline this form. We only inline when the features are
|
||||
;; there (checked above) and when the C types are part of this machine
|
||||
;; (checked here).
|
||||
(loop for type in (list* return-rep-type arg-types)
|
||||
(loop for type in (list* return-host-type arg-types)
|
||||
unless (or (eq type 'fixnum-float)
|
||||
(and (consp type) (eq (car type) 'values))
|
||||
(lisp-type-p type)
|
||||
(machine-c-type-p type))
|
||||
do (warn "Dropping inline form for ~A because of missing type ~A" name type)
|
||||
(return-from %def-inline))
|
||||
(setf arg-rep-types
|
||||
(mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->rep-type x)))
|
||||
(setf arg-host-types
|
||||
(mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->host-type x)))
|
||||
arg-types))
|
||||
(when (eq return-rep-type t)
|
||||
(setf return-rep-type :object))
|
||||
(let* ((return-type (if (and (consp return-rep-type)
|
||||
(eq (first return-rep-type) 'values))
|
||||
(when (eq return-host-type t)
|
||||
(setf return-host-type :object))
|
||||
(let* ((return-type (if (and (consp return-host-type)
|
||||
(eq (first return-host-type) 'values))
|
||||
t
|
||||
(rep-type->lisp-type return-rep-type)))
|
||||
(host-type->lisp-type return-host-type)))
|
||||
(inline-info
|
||||
(make-inline-info :name name
|
||||
:arg-rep-types arg-rep-types
|
||||
:return-rep-type return-rep-type
|
||||
:arg-host-types arg-host-types
|
||||
:return-host-type return-host-type
|
||||
:return-type return-type
|
||||
:arg-types arg-types
|
||||
:exact-return-type exact-return-type
|
||||
|
|
|
|||
|
|
@ -13,11 +13,11 @@
|
|||
|
||||
(defstruct machine
|
||||
(c-types '())
|
||||
rep-type-hash
|
||||
host-type-hash
|
||||
sorted-types
|
||||
inline-information)
|
||||
|
||||
(defstruct (rep-type (:constructor %make-rep-type))
|
||||
(defstruct (host-type (:constructor %make-host-type))
|
||||
(index 0) ; Precedence order in the type list
|
||||
(name t)
|
||||
(lisp-type t)
|
||||
|
|
@ -32,63 +32,63 @@
|
|||
(defun lisp-type-p (type)
|
||||
(subtypep type 'T))
|
||||
|
||||
(defun rep-type-record-unsafe (rep-type)
|
||||
(gethash rep-type (machine-rep-type-hash *machine*)))
|
||||
(defun host-type-record-unsafe (host-type)
|
||||
(gethash host-type (machine-host-type-hash *machine*)))
|
||||
|
||||
(defun rep-type-record (rep-type)
|
||||
(ext:if-let ((record (gethash rep-type (machine-rep-type-hash *machine*))))
|
||||
(defun host-type-record (host-type)
|
||||
(ext:if-let ((record (gethash host-type (machine-host-type-hash *machine*))))
|
||||
record
|
||||
(cmperr "Not a valid C type name ~A" rep-type)))
|
||||
(cmperr "Not a valid C type name ~A" host-type)))
|
||||
|
||||
(defun rep-type->lisp-type (name)
|
||||
(let ((output (rep-type-record-unsafe name)))
|
||||
(defun host-type->lisp-type (name)
|
||||
(let ((output (host-type-record-unsafe name)))
|
||||
(cond (output
|
||||
(rep-type-lisp-type output))
|
||||
(host-type-lisp-type output))
|
||||
((lisp-type-p name) name)
|
||||
(t (error "Unknown representation type ~S" name)))))
|
||||
|
||||
(defun lisp-type->rep-type (type)
|
||||
(defun lisp-type->host-type (type)
|
||||
(cond
|
||||
;; We expect type = NIL when we have no information. Should be fixed. FIXME!
|
||||
((null type)
|
||||
:object)
|
||||
((let ((r (rep-type-record-unsafe type)))
|
||||
(and r (rep-type-name r))))
|
||||
((let ((r (host-type-record-unsafe type)))
|
||||
(and r (host-type-name r))))
|
||||
(t
|
||||
;; Find the most specific type that fits
|
||||
(dolist (record (machine-sorted-types *machine*) :object)
|
||||
(when (subtypep type (rep-type-lisp-type record))
|
||||
(return-from lisp-type->rep-type (rep-type-name record)))))))
|
||||
(when (subtypep type (host-type-lisp-type record))
|
||||
(return-from lisp-type->host-type (host-type-name record)))))))
|
||||
|
||||
(defun c-number-rep-type-p (rep-type)
|
||||
(let ((r (rep-type-record-unsafe rep-type)))
|
||||
(and r (rep-type-numberp r))))
|
||||
(defun c-number-host-type-p (host-type)
|
||||
(let ((r (host-type-record-unsafe host-type)))
|
||||
(and r (host-type-numberp r))))
|
||||
|
||||
(defun c-integer-rep-type-p (rep-type)
|
||||
(let ((r (rep-type-record-unsafe rep-type)))
|
||||
(and r (rep-type-integerp r))))
|
||||
(defun c-integer-host-type-p (host-type)
|
||||
(let ((r (host-type-record-unsafe host-type)))
|
||||
(and r (host-type-integerp r))))
|
||||
|
||||
(defun c-integer-rep-type-bits (rep-type)
|
||||
(let ((r (rep-type-record-unsafe rep-type)))
|
||||
(and r (rep-type-bits r))))
|
||||
(defun c-integer-host-type-bits (host-type)
|
||||
(let ((r (host-type-record-unsafe host-type)))
|
||||
(and r (host-type-bits r))))
|
||||
|
||||
(defun c-number-type-p (type)
|
||||
(c-number-rep-type-p (lisp-type->rep-type type)))
|
||||
(c-number-host-type-p (lisp-type->host-type type)))
|
||||
|
||||
(defun c-integer-type-p (type)
|
||||
(c-integer-rep-type-p (lisp-type->rep-type type)))
|
||||
(c-integer-host-type-p (lisp-type->host-type type)))
|
||||
|
||||
(defun c-integer-type-bits (type)
|
||||
(c-number-rep-type-bits (lisp-type->rep-type type)))
|
||||
(c-number-host-type-bits (lisp-type->host-type type)))
|
||||
|
||||
(defun rep-type->c-name (type)
|
||||
(rep-type-c-name (rep-type-record type)))
|
||||
(defun host-type->c-name (type)
|
||||
(host-type-c-name (host-type-record type)))
|
||||
|
||||
;; These types can be used by ECL to unbox data They are sorted from
|
||||
;; the most specific, to the least specific one. All functions must
|
||||
;; be declared in external.h (not internal.h) header file.
|
||||
(defconstant +representation-types+
|
||||
;; ffi-type lisp type c type convert C->Lisp convert Lisp->C unbox Lisp->C (unsafe)
|
||||
(defconstant +host-types+
|
||||
;; host type lisp type c type convert C->Lisp convert Lisp->C unbox Lisp->C (unsafe)
|
||||
'((:byte . #1=((signed-byte 8) "int8_t" "ecl_make_int8_t" "ecl_to_int8_t" "ecl_fixnum"))
|
||||
(:unsigned-byte . #2=((unsigned-byte 8) "uint8_t" "ecl_make_uint8_t" "ecl_to_uint8_t" "ecl_fixnum"))
|
||||
(:fixnum integer "cl_fixnum" "ecl_make_fixnum" "ecl_to_fixnum" "ecl_fixnum")
|
||||
|
|
@ -177,7 +177,7 @@
|
|||
(:void)
|
||||
(:pointer-void)))
|
||||
|
||||
(defun make-rep-type (all-c-types name lisp-type c-name &optional to-lisp from-lisp from-lisp-unsafe)
|
||||
(defun make-host-type (all-c-types name lisp-type c-name &optional to-lisp from-lisp from-lisp-unsafe)
|
||||
(let* ((record (assoc name all-c-types))
|
||||
(bits (cdr record)))
|
||||
(when record
|
||||
|
|
@ -187,7 +187,7 @@
|
|||
(setf lisp-type `(unsigned-byte ,bits))
|
||||
(setf bits (- bits)
|
||||
lisp-type `(signed-byte ,bits))))
|
||||
(%make-rep-type
|
||||
(%make-host-type
|
||||
:name name
|
||||
:lisp-type lisp-type
|
||||
:bits bits
|
||||
|
|
@ -201,34 +201,34 @@
|
|||
(defun default-machine ()
|
||||
(let* ((all-c-types (append +this-machine-c-types+ +all-machines-c-types+))
|
||||
(table (make-hash-table :size 128 :test 'eq))
|
||||
(sorted-rep-types
|
||||
;; Create the rep-type objects
|
||||
(sorted-host-types
|
||||
;; Create the host-type objects
|
||||
(loop for i from 0
|
||||
for record in +representation-types+
|
||||
for rep-type = (apply #'make-rep-type all-c-types record)
|
||||
when rep-type
|
||||
do (setf (rep-type-index rep-type) i)
|
||||
and collect (setf (gethash (rep-type-name rep-type) table) rep-type))))
|
||||
for record in +host-types+
|
||||
for host-type = (apply #'make-host-type all-c-types record)
|
||||
when host-type
|
||||
do (setf (host-type-index host-type) i)
|
||||
and collect (setf (gethash (host-type-name host-type) table) host-type))))
|
||||
;; hack: sse-pack -> int, but int -> int-sse-pack
|
||||
(let ((r (gethash :int-sse-pack table)))
|
||||
(when r
|
||||
(setf (rep-type-index r) 'ext:int-sse-pack)))
|
||||
(setf (host-type-index r) 'ext:int-sse-pack)))
|
||||
;; On a second pass, we replace types with more general ones
|
||||
(loop with fixnum-rep-type = (gethash ':fixnum table)
|
||||
with fixnum-lisp-type = (rep-type-lisp-type fixnum-rep-type)
|
||||
for (name . rest) in +representation-types+
|
||||
(loop with fixnum-host-type = (gethash ':fixnum table)
|
||||
with fixnum-lisp-type = (host-type-lisp-type fixnum-host-type)
|
||||
for (name . rest) in +host-types+
|
||||
for r = (gethash name table)
|
||||
when (and r (subtypep (rep-type-lisp-type r) fixnum-lisp-type))
|
||||
do (setf (rep-type-from-lisp-unsafe r) "ecl_fixnum"))
|
||||
when (and r (subtypep (host-type-lisp-type r) fixnum-lisp-type))
|
||||
do (setf (host-type-from-lisp-unsafe r) "ecl_fixnum"))
|
||||
;; Create machine object
|
||||
(make-machine :c-types all-c-types
|
||||
:rep-type-hash table
|
||||
:sorted-types sorted-rep-types)))
|
||||
:host-type-hash table
|
||||
:sorted-types sorted-host-types)))
|
||||
|
||||
(defun machine-c-type-p (name)
|
||||
(gethash name (machine-rep-type-hash *machine*)))
|
||||
(gethash name (machine-host-type-hash *machine*)))
|
||||
|
||||
(defun machine-fixnump (number)
|
||||
(typep number (rep-type-lisp-type (gethash :fixnum number))))
|
||||
(typep number (host-type-lisp-type (gethash :fixnum number))))
|
||||
|
||||
(defvar *default-machine* (setf *machine* (default-machine)))
|
||||
|
|
|
|||
|
|
@ -19,12 +19,12 @@
|
|||
(defun make-single-constant-optimizer (name c-value)
|
||||
(cond ((symbolp name)
|
||||
(let* ((value (symbol-value name))
|
||||
(rep-type (lisp-type->rep-type (type-of value)))
|
||||
(location (make-vv :location c-value :value value :rep-type rep-type)))
|
||||
(host-type (lisp-type->host-type (type-of value)))
|
||||
(location (make-vv :location c-value :value value :host-type host-type)))
|
||||
(cons value location)))
|
||||
((floatp name)
|
||||
(let* ((value name)
|
||||
(location (make-vv :location c-value :value value :rep-type :object)))
|
||||
(location (make-vv :location c-value :value value :host-type :object)))
|
||||
(cons value location)))
|
||||
(t
|
||||
(cons name (make-vv :location c-value :value name)))))
|
||||
|
|
|
|||
|
|
@ -19,15 +19,15 @@
|
|||
;;;
|
||||
(define-c-inliner shift (return-type argument orig-shift)
|
||||
(let* ((arg-type (inlined-arg-type argument))
|
||||
(arg-c-type (lisp-type->rep-type arg-type))
|
||||
(return-c-type (lisp-type->rep-type return-type))
|
||||
(arg-c-type (lisp-type->host-type arg-type))
|
||||
(return-c-type (lisp-type->host-type return-type))
|
||||
(shift (loc-immediate-value (inlined-arg-loc orig-shift))))
|
||||
(if (or (not (c-integer-rep-type-p arg-c-type))
|
||||
(not (c-integer-rep-type-p return-c-type)))
|
||||
(if (or (not (c-integer-host-type-p arg-c-type))
|
||||
(not (c-integer-host-type-p return-c-type)))
|
||||
(produce-inline-loc (list argument orig-shift) '(:object :fixnum) '(:object)
|
||||
"ecl_ash(#0,#1)" nil t)
|
||||
(let* ((arg-bits (c-integer-rep-type-bits arg-c-type))
|
||||
(return-bits (c-integer-rep-type-bits return-c-type))
|
||||
(let* ((arg-bits (c-integer-host-type-bits arg-c-type))
|
||||
(return-bits (c-integer-host-type-bits return-c-type))
|
||||
(max-type (if (and (plusp shift)
|
||||
(< arg-bits return-bits))
|
||||
return-c-type
|
||||
|
|
@ -44,10 +44,10 @@
|
|||
;;; Inliners for arithmetic operations.
|
||||
;;;
|
||||
|
||||
(defun most-generic-number-rep-type (r1 r2)
|
||||
(let* ((r1 (rep-type-record r1))
|
||||
(r2 (rep-type-record r2)))
|
||||
(rep-type-name (if (< (rep-type-index r1) (rep-type-index r2))
|
||||
(defun most-generic-number-host-type (r1 r2)
|
||||
(let* ((r1 (host-type-record r1))
|
||||
(r2 (host-type-record r2)))
|
||||
(host-type-name (if (< (host-type-index r1) (host-type-index r2))
|
||||
r2
|
||||
r1))))
|
||||
|
||||
|
|
@ -62,13 +62,13 @@
|
|||
;; type that fits the output, to avoid overflow which
|
||||
;; would happen if we used say, long c = (int)a * (int)b
|
||||
;; as the output would be an integer, not a long.
|
||||
(let* ((arg1-rep (lisp-type->rep-type arg1-type))
|
||||
(arg2-rep (lisp-type->rep-type arg2-type))
|
||||
(out-rep (lisp-type->rep-type expected-type))
|
||||
(max-rep (most-generic-number-rep-type
|
||||
(most-generic-number-rep-type
|
||||
(let* ((arg1-rep (lisp-type->host-type arg1-type))
|
||||
(arg2-rep (lisp-type->host-type arg2-type))
|
||||
(out-rep (lisp-type->host-type expected-type))
|
||||
(max-rep (most-generic-number-host-type
|
||||
(most-generic-number-host-type
|
||||
arg1-rep arg2-rep) out-rep))
|
||||
(max-name (rep-type->c-name max-rep)))
|
||||
(max-name (host-type->c-name max-rep)))
|
||||
(produce-inline-loc
|
||||
(list arg1 arg2)
|
||||
(list arg1-rep arg2-rep)
|
||||
|
|
@ -87,15 +87,15 @@
|
|||
(c-number-type-p expected-type)
|
||||
(c-number-type-p arg1-type))
|
||||
(produce-inline-loc (list arg1)
|
||||
(list (lisp-type->rep-type arg1-type))
|
||||
(list (lisp-type->rep-type expected-type))
|
||||
(list (lisp-type->host-type arg1-type))
|
||||
(list (lisp-type->host-type expected-type))
|
||||
non-consing nil t)
|
||||
(produce-inline-loc (list arg1) '(:object :object) '(:object)
|
||||
consing nil t))))
|
||||
|
||||
(define-c-inliner * (return-type &rest arguments &aux arg1 arg2)
|
||||
(when (null arguments)
|
||||
(return (make-vv :rep-type :fixnum :value 1)))
|
||||
(return (make-vv :host-type :fixnum :value 1)))
|
||||
(setf arg1 (pop arguments))
|
||||
(when (null arguments)
|
||||
(return (inlined-arg-loc arg1)))
|
||||
|
|
@ -106,7 +106,7 @@
|
|||
|
||||
(define-c-inliner + (return-type &rest arguments &aux arg1 arg2)
|
||||
(when (null arguments)
|
||||
(return (make-vv :rep-type :fixnum :value 0)))
|
||||
(return (make-vv :host-type :fixnum :value 0)))
|
||||
(setf arg1 (pop arguments))
|
||||
(when (null arguments)
|
||||
(return (inlined-arg-loc arg1)))
|
||||
|
|
@ -133,8 +133,8 @@
|
|||
(cmperr "The C inliner for (FUNCTION /) expected at most 2 arguments."))
|
||||
|
||||
(define-c-inliner float (return-type arg &optional float)
|
||||
(let ((arg-c-type (lisp-type->rep-type (inlined-arg-type arg)))
|
||||
(flt-c-type (and float (lisp-type->rep-type (inlined-arg-type float)))))
|
||||
(let ((arg-c-type (lisp-type->host-type (inlined-arg-type arg)))
|
||||
(flt-c-type (and float (lisp-type->host-type (inlined-arg-type float)))))
|
||||
(if (member arg-c-type '(:float :double :long-double))
|
||||
(when (or (null float) (eq arg-c-type flt-c-type))
|
||||
(inlined-arg-loc arg))
|
||||
|
|
|
|||
|
|
@ -289,7 +289,7 @@
|
|||
((or fixnum character float #|#+complex-float (complex float)|#)
|
||||
(make-vv :value value
|
||||
:location nil
|
||||
:rep-type (lisp-type->rep-type (type-of value))))
|
||||
:host-type (lisp-type->host-type (type-of value))))
|
||||
#+sse2
|
||||
(ext:sse-pack
|
||||
(let* ((bytes (ext:sse-pack-to-vector value '(unsigned-byte 8)))
|
||||
|
|
@ -302,7 +302,7 @@
|
|||
(make-vv :value value
|
||||
:location (format nil "~A(_mm_setr_epi8(~{~A~^,~}))"
|
||||
wrapper (coerce bytes 'list))
|
||||
:rep-type rtype))))
|
||||
:host-type rtype))))
|
||||
(otherwise
|
||||
nil)))
|
||||
|
||||
|
|
@ -315,7 +315,7 @@
|
|||
(defun update-vv (target source)
|
||||
(assert (eql (vv-value target) (vv-value source)))
|
||||
(setf (vv-location target) (vv-location source)
|
||||
(vv-rep-type target) (vv-rep-type source)))
|
||||
(vv-host-type target) (vv-host-type source)))
|
||||
|
||||
(defun insert-vv (vv)
|
||||
(let* ((arr (if (vv-permanent-p vv)
|
||||
|
|
@ -355,7 +355,7 @@
|
|||
;;; module is loaded. Then the code refers to such objects as VV[13].
|
||||
;;;
|
||||
;;; TODO we could further optimize immediate values by duplicating some entries
|
||||
;;; depending on the expected rep-type, to avoid unnecessary coercions.
|
||||
;;; depending on the expected host-type, to avoid unnecessary coercions.
|
||||
(defun optimize-cxx-data (objects)
|
||||
(flet ((optimize-vv (object)
|
||||
(let ((value (vv-value object)))
|
||||
|
|
|
|||
|
|
@ -211,16 +211,16 @@
|
|||
(ecase kind
|
||||
(:jump-t
|
||||
(destructuring-bind (loc) args
|
||||
(case (loc-representation-type loc)
|
||||
(case (loc-host-type loc)
|
||||
(:bool (wt-nl "if (" loc ") "))
|
||||
(:object (wt-nl "if (" loc "!=ECL_NIL) "))
|
||||
(otherwise (wt-nl "if ((") (wt-coerce-loc :object loc) (wt ")!=ECL_NIL) ")))))
|
||||
(:jump-f
|
||||
(destructuring-bind (loc) args
|
||||
(case (loc-representation-type loc)
|
||||
(:bool (wt-nl "if (!(" loc ")) "))
|
||||
(:object (wt-nl "if (Null(" loc ")) "))
|
||||
(otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt ")) ")))))
|
||||
(case (loc-host-type loc)
|
||||
(:bool (wt-nl "if (!(" loc "))"))
|
||||
(:object (wt-nl "if (Null(" loc "))"))
|
||||
(otherwise (wt-nl "if (Null(") (wt-coerce-loc :object loc) (wt "))")))))
|
||||
(:jump-eq
|
||||
(destructuring-bind (x y) args
|
||||
(wt-nl "if (" `(coerce-loc :object ,x) "==" `(coerce-loc :object ,y) ") "))))
|
||||
|
|
|
|||
|
|
@ -143,7 +143,7 @@
|
|||
(labels ((wt-decl (var)
|
||||
(let ((lcl (next-lcl (var-name var))))
|
||||
(wt-nl)
|
||||
(wt (rep-type->c-name (var-rep-type var)) " " *volatile* lcl ";")
|
||||
(wt (host-type->c-name (var-host-type var)) " " *volatile* lcl ";")
|
||||
lcl))
|
||||
(do-decl (var)
|
||||
(when (local var) ; no LCL needed for SPECIAL or LEX
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@
|
|||
;; overflow if we use a smaller integer type (overflows in long long
|
||||
;; computations are taken care of by the compiler before we get to
|
||||
;; this point).
|
||||
#+msvc (princ (cond ((typep value (rep-type->lisp-type :long-long)) "LL")
|
||||
((typep value (rep-type->lisp-type :unsigned-long-long)) "ULL")
|
||||
#+msvc (princ (cond ((typep value (host-type->lisp-type :long-long)) "LL")
|
||||
((typep value (host-type->lisp-type :unsigned-long-long)) "ULL")
|
||||
(t (baboon :format-control
|
||||
"wt-fixnum: The number ~A doesn't fit any integer type."
|
||||
value)))
|
||||
|
|
@ -197,36 +197,36 @@
|
|||
;;; COERCE-LOC
|
||||
;;;
|
||||
|
||||
(defun wt-to-object-conversion (loc-rep-type loc)
|
||||
(defun wt-to-object-conversion (loc-host-type loc)
|
||||
;; FIXME we can do better for constant locations.
|
||||
(let* ((record (rep-type-record loc-rep-type))
|
||||
(coercer (and record (rep-type-to-lisp record))))
|
||||
(let* ((record (host-type-record loc-host-type))
|
||||
(coercer (and record (host-type-to-lisp record))))
|
||||
(unless coercer
|
||||
(cmperr "Cannot coerce C variable of type ~S to lisp object" loc-rep-type))
|
||||
(cmperr "Cannot coerce C variable of type ~S to lisp object" loc-host-type))
|
||||
(wt coercer "(" loc ")")))
|
||||
|
||||
(defun wt-from-object-conversion (dest-type loc-type rep-type loc)
|
||||
(let* ((record (rep-type-record rep-type))
|
||||
(coercer (and record (rep-type-from-lisp record))))
|
||||
(defun wt-from-object-conversion (dest-type loc-type host-type loc)
|
||||
(let* ((record (host-type-record host-type))
|
||||
(coercer (and record (host-type-from-lisp record))))
|
||||
(unless coercer
|
||||
(cmperr "Cannot coerce lisp object to C type ~A" rep-type))
|
||||
(cmperr "Cannot coerce lisp object to C type ~A" host-type))
|
||||
(wt (if (or (policy-assume-no-errors)
|
||||
(subtypep loc-type dest-type))
|
||||
(rep-type-from-lisp-unsafe record)
|
||||
(host-type-from-lisp-unsafe record)
|
||||
coercer)
|
||||
"(" loc ")")))
|
||||
|
||||
(defun wt-coerce-loc (dest-rep-type loc)
|
||||
(setq dest-rep-type (lisp-type->rep-type dest-rep-type))
|
||||
;(print dest-rep-type)
|
||||
(defun wt-coerce-loc (dest-host-type loc)
|
||||
(setq dest-host-type (lisp-type->host-type dest-host-type))
|
||||
;(print dest-host-type)
|
||||
;(print loc)
|
||||
(let* ((dest-type (rep-type->lisp-type dest-rep-type))
|
||||
(let* ((dest-type (host-type->lisp-type dest-host-type))
|
||||
(loc-type (loc-type loc))
|
||||
(loc-rep-type (loc-representation-type loc)))
|
||||
(loc-host-type (loc-host-type loc)))
|
||||
(labels ((coercion-error (&optional (write-zero t))
|
||||
(cmpwarn "Unable to coerce lisp object from type (~S,~S)~%~
|
||||
to C/C++ type (~S,~S)"
|
||||
loc-type loc-rep-type dest-type dest-rep-type)
|
||||
loc-type loc-host-type dest-type dest-host-type)
|
||||
(when write-zero
|
||||
;; It is possible to reach this point due to a bug
|
||||
;; but also due to a failure of the dead code
|
||||
|
|
@ -237,60 +237,60 @@
|
|||
(ensure-valid-object-type (a-lisp-type)
|
||||
(when (subtypep `(AND ,loc-type ,a-lisp-type) NIL)
|
||||
(coercion-error nil))))
|
||||
(when (eq dest-rep-type loc-rep-type)
|
||||
(when (eq dest-host-type loc-host-type)
|
||||
(wt loc)
|
||||
(return-from wt-coerce-loc))
|
||||
(case dest-rep-type
|
||||
(case dest-host-type
|
||||
((:char :unsigned-char :wchar)
|
||||
(case loc-rep-type
|
||||
(case loc-host-type
|
||||
((:char :unsigned-char :wchar)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
(wt "(" (host-type->c-name dest-host-type) ")(" loc ")"))
|
||||
((:object)
|
||||
(ensure-valid-object-type dest-type)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(wt-from-object-conversion dest-type loc-type dest-host-type loc))
|
||||
(otherwise
|
||||
(coercion-error))))
|
||||
((:float :double :long-double)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq loc-rep-type :object)
|
||||
((c-number-host-type-p loc-host-type)
|
||||
(wt "(" (host-type->c-name dest-host-type) ")(" loc ")"))
|
||||
((eq loc-host-type :object)
|
||||
;; We relax the check a bit, because it is valid in C to coerce
|
||||
;; between floats of different types.
|
||||
(ensure-valid-object-type 'FLOAT)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(wt-from-object-conversion dest-type loc-type dest-host-type loc))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:csfloat :cdfloat :clfloat)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq loc-rep-type :object)
|
||||
((c-number-host-type-p loc-host-type)
|
||||
(wt "(" (host-type->c-name dest-host-type) ")(" loc ")"))
|
||||
((eq loc-host-type :object)
|
||||
;; We relax the check a bit, because it is valid in C to coerce
|
||||
;; between COMPLEX floats of different types.
|
||||
(ensure-valid-object-type 'SI:COMPLEX-FLOAT)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(wt-from-object-conversion dest-type loc-type dest-host-type loc))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:bool)
|
||||
(cond
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
((c-number-host-type-p loc-host-type)
|
||||
(wt "1"))
|
||||
((eq loc-rep-type :object)
|
||||
((eq loc-host-type :object)
|
||||
(wt "(" loc ")!=ECL_NIL"))
|
||||
(t
|
||||
(coercion-error))))
|
||||
((:object)
|
||||
(case loc-rep-type
|
||||
(case loc-host-type
|
||||
((:int-sse-pack :float-sse-pack :double-sse-pack)
|
||||
(when (>= (cmp-env-optimization 'speed) 1)
|
||||
(cmpwarn-style "Boxing a value of type ~S - performance degraded."
|
||||
loc-rep-type))))
|
||||
(wt-to-object-conversion loc-rep-type loc))
|
||||
loc-host-type))))
|
||||
(wt-to-object-conversion loc-host-type loc))
|
||||
((:pointer-void)
|
||||
(case loc-rep-type
|
||||
(case loc-host-type
|
||||
((:object)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(wt-from-object-conversion dest-type loc-type dest-host-type loc))
|
||||
((:cstring)
|
||||
(wt "(char *)(" loc ")"))
|
||||
(otherwise
|
||||
|
|
@ -298,7 +298,7 @@
|
|||
((:cstring)
|
||||
(coercion-error))
|
||||
((:char*)
|
||||
(case loc-rep-type
|
||||
(case loc-host-type
|
||||
((:object)
|
||||
(wt "ecl_base_string_pointer_safe(" loc ")"))
|
||||
((:pointer-void)
|
||||
|
|
@ -306,19 +306,19 @@
|
|||
(otherwise
|
||||
(coercion-error))))
|
||||
((:int-sse-pack :float-sse-pack :double-sse-pack)
|
||||
(case loc-rep-type
|
||||
(case loc-host-type
|
||||
((:object)
|
||||
(wt-from-object-conversion 'ext:sse-pack loc-type dest-rep-type loc))
|
||||
(wt-from-object-conversion 'ext:sse-pack loc-type dest-host-type loc))
|
||||
;; Implicitly cast between SSE subtypes
|
||||
((:int-sse-pack :float-sse-pack :double-sse-pack)
|
||||
(wt (ecase dest-rep-type
|
||||
(:int-sse-pack (ecase loc-rep-type
|
||||
(wt (ecase dest-host-type
|
||||
(:int-sse-pack (ecase loc-host-type
|
||||
(:float-sse-pack "_mm_castps_si128")
|
||||
(:double-sse-pack "_mm_castpd_si128")))
|
||||
(:float-sse-pack (ecase loc-rep-type
|
||||
(:float-sse-pack (ecase loc-host-type
|
||||
(:int-sse-pack "_mm_castsi128_ps")
|
||||
(:double-sse-pack "_mm_castpd_ps")))
|
||||
(:double-sse-pack (ecase loc-rep-type
|
||||
(:double-sse-pack (ecase loc-host-type
|
||||
(:int-sse-pack "_mm_castsi128_pd")
|
||||
(:float-sse-pack "_mm_castps_pd"))))
|
||||
"(" loc ")"))
|
||||
|
|
@ -327,13 +327,13 @@
|
|||
(t
|
||||
;; At this point we only have coercions to integers
|
||||
(cond
|
||||
((not (c-integer-rep-type-p dest-rep-type))
|
||||
((not (c-integer-host-type-p dest-host-type))
|
||||
(coercion-error))
|
||||
((c-number-rep-type-p loc-rep-type)
|
||||
(wt "(" (rep-type->c-name dest-rep-type) ")(" loc ")"))
|
||||
((eq :object loc-rep-type)
|
||||
((c-number-host-type-p loc-host-type)
|
||||
(wt "(" (host-type->c-name dest-host-type) ")(" loc ")"))
|
||||
((eq :object loc-host-type)
|
||||
(ensure-valid-object-type dest-type)
|
||||
(wt-from-object-conversion dest-type loc-type dest-rep-type loc))
|
||||
(wt-from-object-conversion dest-type loc-type dest-host-type loc))
|
||||
(t
|
||||
(coercion-error))))))))
|
||||
|
||||
|
|
@ -342,8 +342,8 @@
|
|||
;;; INLINE-LOC
|
||||
;;;
|
||||
|
||||
(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars)
|
||||
(declare (ignore output-rep-type side-effects))
|
||||
(defun wt-c-inline-loc (output-host-type c-expression coerced-arguments side-effects output-vars)
|
||||
(declare (ignore output-host-type side-effects))
|
||||
(with-input-from-string (s c-expression)
|
||||
(when (and output-vars (not (eq output-vars 'VALUES)))
|
||||
(wt-nl))
|
||||
|
|
@ -403,7 +403,7 @@
|
|||
(progn
|
||||
(wt-nl)
|
||||
(wt-loc destination) (wt " = ")
|
||||
(wt-coerce-loc (loc-representation-type destination) loc)
|
||||
(wt-coerce-loc (loc-host-type destination) loc)
|
||||
(wt ";"))))))
|
||||
|
||||
(defun set-the-loc (loc type orig-loc)
|
||||
|
|
|
|||
|
|
@ -271,7 +271,7 @@
|
|||
(with-bir-env (:env 0 :level 0 :volatile "volatile ")
|
||||
(when (eql return-type :void)
|
||||
(setf return-p nil))
|
||||
(let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type)))
|
||||
(let ((return-type-name (host-type->c-name (ffi::%convert-to-arg-type return-type)))
|
||||
(vars (loop for n from 0 below (length arg-types)
|
||||
collect (format nil "var~d" n)))
|
||||
(fmod (case call-type
|
||||
|
|
@ -284,7 +284,7 @@
|
|||
(loop with comma = ""
|
||||
for var in vars
|
||||
for type in arg-types
|
||||
for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type))
|
||||
for arg-type-name = (host-type->c-name (ffi::%convert-to-arg-type type))
|
||||
do (wt-h comma arg-type-name " " var)
|
||||
(wt comma arg-type-name " " var)
|
||||
(setf comma ","))
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@
|
|||
do (when kind
|
||||
(maybe-open-inline-block)
|
||||
(bind (next-lcl (var-name var)) var)
|
||||
(wt-nl *volatile* (rep-type->c-name kind) " " var ";")))
|
||||
(wt-nl *volatile* (host-type->c-name kind) " " var ";")))
|
||||
|
||||
;; Create closure bindings for closed-over variables
|
||||
(when (some #'var-ref-ccb vars)
|
||||
|
|
@ -159,7 +159,7 @@
|
|||
(when (useful-var-p var)
|
||||
(maybe-open-inline-block)
|
||||
(bind (next-lcl) var)
|
||||
(wt-nl (rep-type->c-name kind) " " *volatile* var ";")
|
||||
(wt-nl (host-type->c-name kind) " " *volatile* var ";")
|
||||
(wt-comment (var-name var)))
|
||||
(unless env-grows (setq env-grows (var-ref-ccb var))))))
|
||||
;; 3) If there are closure variables, set up an environment.
|
||||
|
|
@ -228,11 +228,11 @@
|
|||
(LOCATION (push (cons var (c1form-arg 0 form)) saves))
|
||||
(otherwise
|
||||
(if (local var)
|
||||
(let* ((rep-type (var-rep-type var))
|
||||
(rep-type-c-name (rep-type->c-name rep-type))
|
||||
(temp (make-lcl-var :rep-type rep-type)))
|
||||
(let* ((host-type (var-host-type var))
|
||||
(host-type-c-name (host-type->c-name host-type))
|
||||
(temp (make-lcl-var :host-type host-type)))
|
||||
(wt-nl-open-brace)
|
||||
(wt-nl rep-type-c-name " " *volatile* temp ";")
|
||||
(wt-nl host-type-c-name " " *volatile* temp ";")
|
||||
(let ((*destination* temp)) (c2expr* form))
|
||||
(push (cons var temp) saves))
|
||||
(let ((*destination* (make-temp-var)))
|
||||
|
|
@ -283,7 +283,7 @@
|
|||
;; check they are not the same
|
||||
(unless (equal (var-loc var) loc)
|
||||
(wt-nl var " = ")
|
||||
(wt-coerce-loc (var-rep-type var) loc)
|
||||
(wt-coerce-loc (var-host-type var) loc)
|
||||
(wt ";")))
|
||||
((and (consp loc) (eql (car loc) 'LCL))
|
||||
;; set location for lambda list requireds
|
||||
|
|
@ -412,21 +412,21 @@
|
|||
(case (var-kind var)
|
||||
(CLOSURE
|
||||
(wt-nl)(wt-env var-loc)(wt " = ")
|
||||
(wt-coerce-loc (var-rep-type var) loc)
|
||||
(wt-coerce-loc (var-host-type var) loc)
|
||||
(wt #\;))
|
||||
(LEXICAL
|
||||
(wt-nl)(wt-lex var-loc)(wt " = ")
|
||||
(wt-coerce-loc (var-rep-type var) loc)
|
||||
(wt-coerce-loc (var-host-type var) loc)
|
||||
(wt #\;))
|
||||
((SPECIAL GLOBAL)
|
||||
(if (safe-compile)
|
||||
(wt-nl "ecl_cmp_setq(cl_env_copy," var-loc ",")
|
||||
(wt-nl "ECL_SETQ(cl_env_copy," var-loc ","))
|
||||
(wt-coerce-loc (var-rep-type var) loc)
|
||||
(wt-coerce-loc (var-host-type var) loc)
|
||||
(wt ");"))
|
||||
(t
|
||||
(wt-nl var-loc " = ")
|
||||
(wt-coerce-loc (var-rep-type var) loc)
|
||||
(wt-coerce-loc (var-host-type var) loc)
|
||||
(wt #\;))
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@
|
|||
(always nil) ; when true then vv is never optimized
|
||||
(permanent-p t)
|
||||
(value nil)
|
||||
(rep-type :object))
|
||||
(host-type :object))
|
||||
|
||||
;;; When the value is the "empty location" then it was created to be filled
|
||||
;;; later and the real type of the object is not known. See DATA-EMPTY-LOC.
|
||||
|
|
@ -51,37 +51,37 @@
|
|||
(cond ((eq loc NIL) 'NULL)
|
||||
((var-p loc) (var-type loc))
|
||||
((vv-p loc) (vv-type loc))
|
||||
((numberp loc) (lisp-type->rep-type (type-of loc)))
|
||||
((numberp loc) (lisp-type->host-type (type-of loc)))
|
||||
((atom loc) 'T)
|
||||
(t
|
||||
(case (first loc)
|
||||
(FFI:C-INLINE (let ((type (first (second loc))))
|
||||
(cond ((and (consp type) (eq (first type) 'VALUES)) T)
|
||||
((lisp-type-p type) type)
|
||||
(t (rep-type->lisp-type type)))))
|
||||
(t (host-type->lisp-type type)))))
|
||||
(BIND (var-type (second loc)))
|
||||
(LCL (or (third loc) T))
|
||||
(THE (second loc))
|
||||
(CALL-NORMAL (fourth loc))
|
||||
(otherwise T)))))
|
||||
|
||||
(defun loc-representation-type (loc)
|
||||
(defun loc-host-type (loc)
|
||||
(cond ((member loc '(NIL T)) :object)
|
||||
((var-p loc) (var-rep-type loc))
|
||||
((vv-p loc) (vv-rep-type loc))
|
||||
((numberp loc) (lisp-type->rep-type (type-of loc)))
|
||||
((var-p loc) (var-host-type loc))
|
||||
((vv-p loc) (vv-host-type loc))
|
||||
((numberp loc) (lisp-type->host-type (type-of loc)))
|
||||
((eq loc 'TRASH) :void)
|
||||
((atom loc) :object)
|
||||
(t
|
||||
(case (first loc)
|
||||
(FFI:C-INLINE (let ((type (first (second loc))))
|
||||
(cond ((and (consp type) (eq (first type) 'VALUES)) :object)
|
||||
((lisp-type-p type) (lisp-type->rep-type type))
|
||||
((lisp-type-p type) (lisp-type->host-type type))
|
||||
(t type))))
|
||||
(BIND (var-rep-type (second loc)))
|
||||
(LCL (lisp-type->rep-type (or (third loc) T)))
|
||||
(BIND (var-host-type (second loc)))
|
||||
(LCL (lisp-type->host-type (or (third loc) T)))
|
||||
((JUMP-TRUE JUMP-FALSE) :bool)
|
||||
(THE (loc-representation-type (third loc)))
|
||||
(THE (loc-host-type (third loc)))
|
||||
(otherwise :object)))))
|
||||
|
||||
(defun loc-with-side-effects-p (loc &aux name)
|
||||
|
|
@ -119,14 +119,14 @@
|
|||
;;; ( VALUE i ) VALUES(i)
|
||||
;;; ( VV vv-index )
|
||||
;;; ( VV-temp vv-index )
|
||||
;;; ( LCL lcl [representation-type]) local variable, type unboxed
|
||||
;;; ( LCL lcl [host-type]) local variable, type unboxed
|
||||
;;; ( TEMP temp ) local variable, type object
|
||||
;;; ( FRAME ndx ) variable in local frame stack
|
||||
;;; ( CALL-NORMAL fun locs 1st-type ) similar as CALL, but number of arguments is fixed
|
||||
;;; ( CALL-INDIRECT fun narg args) similar as CALL, but unknown function
|
||||
;;; ( CALL-STACK fun) similar as CALL-INDIRECT, but args are on the stack
|
||||
;;; ( FFI:C-INLINE output-type fun/string locs side-effects output-var )
|
||||
;;; ( COERCE-LOC representation-type location)
|
||||
;;; ( COERCE-LOC host-type location)
|
||||
;;; ( FDEFINITION vv-index )
|
||||
;;; ( MAKE-CCLOSURE cfun )
|
||||
;;; ( STACK-POINTER index ) retrieve a value from the stack
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
(destructuring-bind (arguments arg-types output-type c-expression
|
||||
&rest rest
|
||||
&key (side-effects t) one-liner
|
||||
&aux output-rep-type)
|
||||
&aux output-host-type)
|
||||
args
|
||||
(unless (= (length arguments) (length arg-types))
|
||||
(cmperr "In a C-INLINE form the number of declare arguments and the number of supplied ones do not match:~%~S"
|
||||
|
|
@ -44,21 +44,21 @@
|
|||
;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*)
|
||||
(flet ((produce-type-pair (type)
|
||||
(if (lisp-type-p type)
|
||||
(cons type (lisp-type->rep-type type))
|
||||
(cons (rep-type->lisp-type type) type))))
|
||||
(cons type (lisp-type->host-type type))
|
||||
(cons (host-type->lisp-type type) type))))
|
||||
(cond ((eq output-type ':void)
|
||||
(setf output-rep-type '()
|
||||
(setf output-host-type '()
|
||||
output-type 'NIL))
|
||||
((equal output-type '(VALUES &REST t))
|
||||
(setf output-rep-type '((VALUES &REST t))))
|
||||
(setf output-host-type '((VALUES &REST t))))
|
||||
((and (consp output-type) (eql (first output-type) 'VALUES))
|
||||
(let ((x (mapcar #'produce-type-pair (rest output-type))))
|
||||
(setf output-rep-type (mapcar #'cdr x)
|
||||
(setf output-host-type (mapcar #'cdr x)
|
||||
output-type `(VALUES ,@(mapcar #'car x)))))
|
||||
(t
|
||||
(let ((x (produce-type-pair output-type)))
|
||||
(setf output-type (car x)
|
||||
output-rep-type (list (cdr x)))))))
|
||||
output-host-type (list (cdr x)))))))
|
||||
(unless (and (listp arguments)
|
||||
(listp arg-types)
|
||||
(stringp c-expression))
|
||||
|
|
@ -72,7 +72,7 @@
|
|||
(form (make-c1form* 'ffi:c-inline :type output-type
|
||||
:side-effects side-effects
|
||||
:args arguments arg-types
|
||||
output-rep-type
|
||||
output-host-type
|
||||
c-expression
|
||||
side-effects
|
||||
one-liner)))
|
||||
|
|
|
|||
|
|
@ -224,7 +224,7 @@
|
|||
(setq type 'T))
|
||||
((machine-c-type-p (setq type (cdr type)))
|
||||
(setf kind type
|
||||
type (rep-type->lisp-type type))))
|
||||
type (host-type->lisp-type type))))
|
||||
(cond ((or (member name specials) (special-variable-p name))
|
||||
(unless (eq kind 'LEXICAL)
|
||||
(cmperr "Special variable ~A cannot be declared to have C type ~A"
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@
|
|||
(ext:COMPILER-TYPECASE var expressions)
|
||||
(ext:CHECKED-VALUE type value-c1form let-form)
|
||||
;; Backend-specific operators
|
||||
(FFI:C-INLINE (arg-c1form*) (arg-type-symbol*) output-rep-type
|
||||
(FFI:C-INLINE (arg-c1form*) (arg-type-symbol*) output-host-type
|
||||
c-expression-string
|
||||
side-effects-p one-liner-p)
|
||||
(FFI:C-PROGN variables forms))))
|
||||
|
|
|
|||
|
|
@ -44,12 +44,12 @@
|
|||
(push var (fun-local-vars *current-function*))))
|
||||
var))
|
||||
|
||||
(defun make-lcl-var (&key rep-type (type 'T))
|
||||
(unless rep-type
|
||||
(setq rep-type (if type (lisp-type->rep-type type) :object)))
|
||||
(defun make-lcl-var (&key host-type (type 'T))
|
||||
(unless host-type
|
||||
(setq host-type (if type (lisp-type->host-type type) :object)))
|
||||
(unless type
|
||||
(setq type 'T))
|
||||
(make-var :kind rep-type :type type :loc (next-lcl)))
|
||||
(make-var :kind host-type :type type :loc (next-lcl)))
|
||||
|
||||
(defun make-global-var (name &key
|
||||
(type (or (si:get-sysprop name 'CMP-TYPE) t))
|
||||
|
|
@ -165,7 +165,7 @@
|
|||
(add-to-set-nodes v form))
|
||||
form)
|
||||
|
||||
(defun var-rep-type (var)
|
||||
(defun var-host-type (var)
|
||||
(case (var-kind var)
|
||||
((LEXICAL CLOSURE SPECIAL GLOBAL) :object)
|
||||
(t (var-kind var))))
|
||||
|
|
@ -179,11 +179,11 @@
|
|||
;; if the variable can be stored locally, set it var-kind to its type
|
||||
(setf (var-kind var)
|
||||
(if (plusp (var-ref var))
|
||||
(lisp-type->rep-type (var-type var))
|
||||
(lisp-type->host-type (var-type var))
|
||||
:OBJECT)))))
|
||||
|
||||
(defun unboxed (var)
|
||||
(not (eq (var-rep-type var) :object)))
|
||||
(not (eq (var-host-type var) :object)))
|
||||
|
||||
(defun local (var)
|
||||
(and (not (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue