mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-17 23:02:31 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'cmpc-rework-inline-args' into 'develop'

Browse source 
Remove friction between inlined args and normal locations

See merge request embeddable-common-lisp/ecl!314
This commit is contained in:
Marius Gerbershagen 2024-01-27 15:21:53 +00:00
commit 082c5cefac
25 changed files with 554 additions and 585 deletions
Download patch file Download diff file Expand all files Collapse all files

223
src/cmp/cmpbackend-cxx/cmpc-arg-inl.lsp
View file

@ -7,20 +7,10 @@
;;;;
;;;; Open coding nested forms as C expressions while preserving the order of
;;;; evaluation. Resulting locations stored in the INLINE-ARG structure may be
;;;; used inline in C expressions (locs still must to be coerced appropriately).
;;;; evaluation. Resulting locations may be used inline in C expressions.
(in-package "COMPILER")
(defstruct (inlined-arg (:constructor %make-inlined-arg))
loc
type
rep-type)
(defun make-inlined-arg (loc lisp-type)
(%make-inlined-arg :loc loc :type lisp-type
:rep-type (loc-representation-type loc)))
(defun maybe-open-inline-block ()
(unless (plusp *inline-blocks*)
(open-inline-block)))
@ -33,9 +23,17 @@
(loop for i of-type fixnum from 0 below *inline-blocks*
do (wt-nl-close-brace)))
(defun coerce-locs (inlined-args &optional types args-to-be-saved)
(defun coerce-loc (host-type location)
(if (eq (loc-host-type location) host-type)
location
`(COERCE-LOC ,host-type ,location)))
(defun coerce-args (inlined-args)
(mapcar (lambda (loc) (coerce-loc :object loc)) inlined-args))
(defun coerce-locs (inlined-args types args-to-be-saved)
;; INLINED-ARGS is a list of INLINED-ARG produced by the argument inliner.
;; The structure contains a location, a lisp type, and the mach rep type.
;; Each arg is a location, "inlined" means "evaluated in the correct order".
;;
;; ARGS-TO-BE-SAVED is a positional list created by C-INLINE, instructing that
;; the value should be saved in a temporary variable.
@ -43,148 +41,113 @@
;; TYPES is a list of destination types, to which the former values are
;; coerced. The destination type can be:
;;
;; - A machine rep type (:OBJECT, :FIXNUM, :INT, ...)
;; - A host type (:OBJECT, :FIXNUM, :INT, :CHAR, ...)
;; - A lisp type (T, INTEGER, STRING, CHARACTER, ...))
;;
(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 type in (or types '#1=(:object . #1#))
for loc in inlined-args
for type in types
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)))
(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 ";")
lcl))
((equal rep-type arg-rep-type)
loc)
(t
`(COERCE-LOC ,rep-type ,loc)))))
(if (and (member i args-to-be-saved :test #'eql)
(not (loc-movable-p loc)))
(let ((lcl (make-lcl-var :host-type host-type)))
(wt-nl)
(unless block-opened
(setf block-opened t)
(open-inline-block))
(wt (host-type->c-name host-type) " " lcl "= "
(coerce-loc host-type loc) ";")
lcl)
(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)
(make-temp-var value-type)
(let ((var (make-lcl-var :rep-type out-rep-type
:type value-type)))
(open-inline-block)
(wt-nl (rep-type->c-name out-rep-type) " " var ";")
var))))
;;; We could use VV to represent inlined args, but the most specific for our
;;; purposes is the location (THE LISP-TYPE LOCATION) which is created when
;;; necessary by the function PRECISE-LOC-TYPE. -- jd 2023-12-06
#+ (or)
(defun make-inlined-arg (loc lisp-type)
(make-vv :location loc
:value *inline-loc*
:type lisp-type
:host-type (loc-host-type loc)))
(defun make-inlined-temp-var (lisp-type host-type)
(if (eq host-type :object)
(make-temp-var lisp-type)
(let ((var (make-lcl-var :host-type host-type
:type lisp-type)))
(open-inline-block)
(wt-nl (host-type->c-name host-type) " " var ";")
var)))
(defun emit-inlined-temp-var (form lisp-type host-type)
(let ((*destination* (make-inlined-temp-var lisp-type host-type)))
(c2expr* form)
*destination*))
(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))))
(set-loc temp var)
(make-inlined-arg temp lisp-type))
(make-inlined-arg var lisp-type))))
(emit-inlined-temp-var form lisp-type (var-host-type var))
(precise-loc-lisp-type var lisp-type))))
(defun emit-inlined-setq (form rest-forms)
(let ((vref (c1form-arg 0 form))
(form1 (c1form-arg 1 form)))
(let ((*destination* vref))
(c2expr* form1))
(if (eq (c1form-name form1) 'LOCATION)
(make-inlined-arg (c1form-arg 0 form1) (c1form-primary-type form1))
(emit-inlined-variable (make-c1form 'VARIABLE form vref nil) rest-forms))))
(let ((var (c1form-arg 0 form))
(val-form (c1form-arg 1 form))
(lisp-type (c1form-primary-type form)))
(let ((*destination* var))
(c2expr* val-form))
(cond
((eq (c1form-name val-form) 'LOCATION)
(precise-loc-lisp-type (c1form-arg 0 val-form) lisp-type))
((not (var-changed-in-form-list var rest-forms))
(precise-loc-lisp-type var lisp-type))
(t
(let ((var-form (make-c1form 'VARIABLE form var nil)))
(emit-inlined-temp-var var-form lisp-type (var-host-type var)))))))
(defun emit-inlined-call-global (form expected-type)
(let* ((fname (c1form-arg 0 form))
(args (c1form-arg 1 form))
(return-type (c1form-primary-type form))
(fun (find fname *global-funs* :key #'fun-name :test #'same-fname-p))
(loc (call-global-loc fname fun args return-type expected-type))
(type (type-and return-type (loc-type loc)))
(temp (make-inline-temp-var type (loc-representation-type loc))))
(set-loc temp loc)
(make-inlined-arg temp type)))
(defun emit-inlined-progn (form forms)
(defun emit-inlined-progn (form rest-forms)
(let ((args (c1form-arg 0 form)))
(loop with *destination* = 'TRASH
while (rest args)
do (c2expr* (pop args)))
(emit-inline-form (first args) forms)))
(emit-inline-form (first args) rest-forms)))
(defun emit-inlined-values (form forms)
(defun emit-inlined-values (form rest-forms)
(let ((args (c1form-arg 0 form)))
(prog1 (emit-inline-form (or (pop args) (c1nil))
;; the rest of the values args need to be
;; added to the rest forms to execute side
;; effects in the correct order
(append args forms))
;; The rest of the values args need to be added to
;; the rest forms to execute side effects in the
;; correct order.
(append args rest-forms))
(loop with *destination* = 'TRASH
for form in args
do (c2expr* form)))))
(defun emit-inlined-structure-ref (form rest-forms)
(let ((type (c1form-primary-type form)))
(if (some #'c1form-side-effects rest-forms)
(let* ((temp (make-inline-temp-var type :object))
(*destination* temp))
(c2expr* form)
(make-inlined-arg temp type))
(make-inlined-arg (list 'SI:STRUCTURE-REF
(first (coerce-locs
(inline-args (list (c1form-arg 0 form)))))
(c1form-arg 1 form)
(c1form-arg 2 form)
(c1form-arg 3 form))
type))))
(defun emit-inlined-instance-ref (form rest-forms)
(let ((type (c1form-primary-type form)))
(if (some #'c1form-side-effects rest-forms)
(let* ((temp (make-inline-temp-var type :object))
(*destination* temp))
(c2expr* form)
(make-inlined-arg temp type))
(make-inlined-arg (list 'SI:INSTANCE-REF
(first (coerce-locs
(inline-args (list (c1form-arg 0 form)))))
(c1form-arg 1 form)
#+ (or) (c1form-arg 2 form))
type))))
;;;
;;; emit-inline-form:
;;; returns a location that contains a moveable argument
;;; side effects: emits code for a temporary variable
;;;
;;; Whoever calls this function must wrap the body in WITH-INLINE-BLOCKS.
;;;
(defun emit-inline-form (form forms)
(with-c1form-env (form form)
(case (c1form-name form)
(LOCATION
(make-inlined-arg (c1form-arg 0 form) (c1form-primary-type form)))
(VARIABLE
(emit-inlined-variable form forms))
(CALL-GLOBAL
(emit-inlined-call-global form (c1form-primary-type form)))
(SI:STRUCTURE-REF
(emit-inlined-structure-ref form forms))
(SI:INSTANCE-REF
(emit-inlined-instance-ref form forms))
(SETQ
(emit-inlined-setq form forms))
(PROGN
(emit-inlined-progn form forms))
(VALUES
(emit-inlined-values form forms))
(t (let* ((type (c1form-primary-type form))
(temp (make-inline-temp-var type))
(*destination* temp))
(c2expr* form)
(make-inlined-arg temp type))))))
(precise-loc-lisp-type
(case (c1form-name form)
(LOCATION (c1form-arg 0 form) )
(VARIABLE (emit-inlined-variable form forms))
(SETQ (emit-inlined-setq form forms))
(PROGN (emit-inlined-progn form forms))
(VALUES (emit-inlined-values form forms))
(t (emit-inlined-temp-var form t :object)))
(c1form-primary-type form))))
;;;
;;; inline-args:
;;; returns a list of pairs (type loc)
;;; returns locations that contain results of evaluating forms
;;; side effects: emits code for temporary variables
;;;
;;; Whoever calls this function must wrap the body in WITH-INLINE-BLOCKS.
@ -193,13 +156,3 @@
(loop for form-list on forms
for form = (first form-list)
collect (emit-inline-form form (rest form-list))))
;;;
;;; inline-arg0:
;;; returns a location that contains the function
;;; side effects: emits code for a temporary variable
;;;
;;; Whoever calls this function must wrap the body in WITH-INLINE-BLOCKS.
;;;
(defun inline-arg0 (value-form other-forms)
(emit-inline-form value-form other-forms))

66
src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp
View file

@ -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
@ -38,7 +38,7 @@
(default-c-inliner fname return-type inlined-args)))
(defun default-c-inliner (fname return-type inlined-args)
(let* ((arg-types (mapcar #'inlined-arg-type inlined-args))
(let* ((arg-types (mapcar #'loc-lisp-type inlined-args))
(ii (inline-function fname arg-types return-type)))
(and ii (apply-inline-info ii inlined-args))))
@ -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 (loc-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*)))))))

26
src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp
View file

@ -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

100
src/cmp/cmpbackend-cxx/cmpc-mach.lsp
View file

@ -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)))

6
src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp
View file

@ -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)))))

60
src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp
View file

@ -18,16 +18,16 @@
;;; cases the compiler may do whatever it wants (and gcc does!)
;;;
(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))
(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)))
(let* ((arg-type (loc-lisp-type argument))
(arg-c-type (lisp-type->host-type arg-type))
(return-c-type (lisp-type->host-type return-type))
(shift (loc-immediate-value orig-shift)))
(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,16 +44,16 @@
;;; 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))))
(defun inline-binop (expected-type arg1 arg2 consing non-consing)
(let ((arg1-type (inlined-arg-type arg1))
(arg2-type (inlined-arg-type arg2)))
(let ((arg1-type (loc-lisp-type arg1))
(arg2-type (loc-lisp-type arg2)))
(if (and (policy-assume-right-type)
(c-number-type-p expected-type)
(c-number-type-p arg1-type)
@ -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)
@ -82,23 +82,23 @@
consing nil t))))
(defun inline-arith-unop (expected-type arg1 consing non-consing)
(let ((arg1-type (inlined-arg-type arg1)))
(let ((arg1-type (loc-lisp-type arg1)))
(if (and (policy-assume-right-type)
(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)))
(return arg1))
(setf arg2 (pop arguments))
(when (null arguments)
(return (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)))
@ -106,10 +106,10 @@
(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)))
(return arg1))
(setf arg2 (pop arguments))
(when (null arguments)
(return (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)))
@ -133,11 +133,11 @@
(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 (loc-lisp-type arg)))
(flt-c-type (and float (lisp-type->host-type (loc-lisp-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))
arg)
(when (member flt-c-type '(:float :double :long-double))
(produce-inline-loc (list arg)
(list :object)

2
src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp
View file

@ -16,7 +16,7 @@
(unless stream
(setf stream (emit-inline-form (c1nil) nil)))
(multiple-value-bind (foundp value)
(loc-immediate-value-p (inlined-arg-loc expression))
(loc-immediate-value-p expression)
(cond
((and foundp (characterp value))
(produce-inline-loc (list expression stream)

3
src/cmp/cmpbackend-cxx/cmpc-util.lsp
View file

@ -194,7 +194,8 @@
;;; for temporary variables that are bound to local evaluation results.
(defmacro with-inline-blocks (() &body body)
`(let ((*inline-blocks* 0)
(*temp* *temp*))
(*temp* *temp*)
(*lcl* *lcl*))
,@body
(close-inline-blocks)))

14
src/cmp/cmpbackend-cxx/cmppass2-call.lsp
View file

@ -48,7 +48,7 @@
(defun c2call-stack (c1form form args values-p)
(declare (ignore c1form))
(with-stack-frame (frame)
(let ((loc (inlined-arg-loc (inline-arg0 form args))))
(let ((loc (emit-inline-form form args)))
(let ((*destination* (if values-p 'VALUEZ 'LEAVE)))
(dolist (arg args)
(c2expr* arg)
@ -70,7 +70,7 @@
(unwind-exit (call-global-loc fname fun
(inline-args args)
(type-and (c1form-primary-type c1form)
(loc-type *destination*))))))
(loc-lisp-type *destination*))))))
;;;
;;; c2call-local:
@ -90,7 +90,7 @@
(let* ((form-type (c1form-primary-type form))
(function-p (and (subtypep form-type 'function)
(policy-assume-right-type)))
(loc (inlined-arg-loc (inline-arg0 form args)))
(loc (emit-inline-form form args))
(args (inline-args args)))
(unwind-exit (call-unknown-global-loc loc args function-p))))
@ -157,7 +157,7 @@
;;;
(defun call-loc (fname fun args type)
(declare (ignore fname))
`(CALL-NORMAL ,fun ,(coerce-locs args) ,type))
`(CALL-NORMAL ,fun ,(coerce-args args) ,type))
;;;
;;; call-global:
@ -252,7 +252,7 @@
;;; FUNCTION-P: true when we can assume that LOC is the function
;;;
(defun call-unknown-global-loc (loc args function-p)
`(CALL-INDIRECT ,loc ,(coerce-locs args) nil ,function-p))
`(CALL-INDIRECT ,loc ,(coerce-args args) nil ,function-p))
;;;
;;; call-unknown-global-fun
@ -261,10 +261,10 @@
;;; ARGS: a list of INLINED-ARGs
;;;
(defun call-unknown-global-fun (fname args)
`(CALL-INDIRECT (FDEFINITION ,fname) ,(coerce-locs args) ,fname t))
`(CALL-INDIRECT (FDEFINITION ,fname) ,(coerce-args args) ,fname t))
#+ (or)
;;; This version is correct but unnecessarily slow - it goes through
;;; ecl_function_dispatch. wt-fdefinition handles all proper names.
(defun call-unknown-global-fun (fname args)
`(CALL-INDIRECT ,(get-object fname) ,(coerce-locs args) ,fname nil))
`(CALL-INDIRECT ,(get-object fname) ,(coerce-args args) ,fname nil))

4
src/cmp/cmpbackend-cxx/cmppass2-cont.lsp
View file

@ -31,7 +31,7 @@
;; var is referenced from a closure which may escape.
(let ((env-lvl *env-lvl*))
(wt-nl "cl_object " *volatile* "env" (incf *env-lvl*) " = env" env-lvl ";")))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" blk-var)
(bind 'FRAME++ blk-var)
(with-unwind-frame (blk-var)
(unwind-exit 'VALUEZ)
(c2expr body))
@ -77,7 +77,7 @@
(setf (var-loc tag-loc) (next-lcl))
(maybe-open-inline-block)
(wt-nl "cl_object " tag-loc ";"))
(bind "ECL_NEW_FRAME_ID(cl_env_copy)" tag-loc)
(bind 'FRAME++ tag-loc)
(with-unwind-frame (tag-loc)
(progn
(do-tags (tag body nil)

12
src/cmp/cmpbackend-cxx/cmppass2-data.lsp
View file

@ -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)))
@ -409,9 +409,7 @@
(wt-vv-index index (vv-permanent-p vv-loc)))))
(defun set-vv-index (loc index permanent-p)
(wt-nl) (wt-vv-index index permanent-p) (wt "= ")
(wt-coerce-loc :object loc)
(wt ";"))
(wt-nl) (wt-vv-index index permanent-p) (wt "=" (coerce-loc :object loc) ";"))
(defun set-vv (loc vv-loc)
(setf (vv-used-p vv-loc) t)

6
src/cmp/cmpbackend-cxx/cmppass2-eval.lsp
View file

@ -14,7 +14,9 @@
(let* ((name (c1form-name form))
(args (c1form-args form))
(dispatch (gethash name *c2-dispatch-table*)))
(apply dispatch form args))))
(if dispatch
(apply dispatch form args)
(cmperr "Unhandled C2FORM found at the:~%~4I~A" form)))))
(defun c2expr* (form)
;; C2EXPR* compiles the giving expression in a context in which
@ -220,7 +222,7 @@
(t
(with-inline-blocks ()
(let* ((nv (length forms))
(forms (nreverse (coerce-locs (inline-args forms)))))
(forms (nreverse (coerce-args (inline-args forms)))))
;; By inlining arguments we make sure that VL has no call to funct.
;; Reverse args to avoid clobbering VALUES(0)
(wt-nl "cl_env_copy->nvalues = " nv ";")

14
src/cmp/cmpbackend-cxx/cmppass2-exit.lsp
View file

@ -211,19 +211,19 @@
(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) ")))))
(otherwise (wt-nl "if ((" (coerce-loc :object loc) ")!=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(" (coerce-loc :object loc) "))")))))
(:jump-eq
(destructuring-bind (x y) args
(wt-nl "if (" `(coerce-loc :object ,x) "==" `(coerce-loc :object ,y) ") "))))
(wt-nl "if (" (coerce-loc :object x) "==" (coerce-loc :object y) ") "))))
(wt-open-brace)
(multiple-value-bind (frs-bind bds-lcl bds-bind stack-frame ihs-p)
(compute-unwind (label-denv exit) from)

6
src/cmp/cmpbackend-cxx/cmppass2-fun.lsp
View file

@ -143,14 +143,14 @@
(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
(when (local-var-p var) ; no LCL needed for SPECIAL or LEX
(setf (var-loc var) (wt-decl var)))))
;; Declare unboxed required arguments
(loop for var in requireds
when (unboxed var)
when (unboxed-var-p var)
do (setf (var-loc var) (wt-decl var)))
;; dont create rest or varargs if not used
(when (and rest (< (var-ref rest) 1)

182
src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
View file

@ -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))
(loc-type (loc-type loc))
(loc-rep-type (loc-representation-type loc)))
(let* ((dest-type (host-type->lisp-type dest-host-type))
(loc-type (loc-lisp-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))
@ -383,6 +383,29 @@
;;; SET-LOC
;;;
;;; Setting the location requires some cooperation between the code that returns
;;; the location and the code that assigns it. By default we treat all RVALs as
;;; having a single value (that's how wt-loc dispatches all known locations).
;;;
;;; This "default" changes when the LVAL expects multiple values. In that case
;;; the SET-LOC method checks whether the RVAL may return multiple values:
;;;
;;; - when it does, then we use these values and do nothing
;;; - when unknown, then we update values[0] and leave nvalues as is
;;; - otherwise we update values[0] and reset nvalues = 1
;;;
;;; The "unknown" requires some explanation. The predicate (USES-VALUES loc)
;;; returns true for locations that possibly can return multiple values. The
;;; most representative example are function calls - the number of returned
;;; values may even change at runtime, because the function may be recompiled.
;;;
;;; The contract between the caller and the callee is that the callee will
;;; ensure upon exit, that nvalues contains the correct value, and that the
;;; returned value is the primary value. When the callee returns only a single
;;; value then it does not update VALUES vector to avoid global memory writes.
;;; This is why LVALs that accept multiple values must assign VALUES[0] when the
;;; (USES-VALUES RVAL) returns T. -- jd 2023-12-14
(defun set-unknown-loc (destination loc)
(unknown-location 'set-loc destination))
@ -402,34 +425,8 @@
(apply fd loc (rest destination))
(progn
(wt-nl)
(wt-loc destination) (wt " = ")
(wt-coerce-loc (loc-representation-type destination) loc)
(wt ";"))))))
(defun set-the-loc (loc type orig-loc)
(declare (ignore type))
(set-loc orig-loc loc))
(defun set-valuez-loc (loc)
(cond ((eq loc 'VALUEZ))
((uses-values loc)
(wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";"))
(t
(wt-nl "cl_env_copy->values[0] = ") (wt-coerce-loc :object loc) (wt ";")
(wt-nl "cl_env_copy->nvalues = 1;"))))
(defun set-value0-loc (loc)
(wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
(defun set-leave-loc (loc)
(cond ((or (eq loc 'VALUEZ) (uses-values loc))
(wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";"))
((eq loc 'VALUE0)
(wt-nl "cl_env_copy->nvalues = 1;"))
((eq loc 'LEAVE))
(t
(wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";")
(wt-nl "cl_env_copy->nvalues = 1;"))))
(wt-loc destination)
(wt " = " (coerce-loc (loc-host-type destination) loc) ";"))))))
(defun set-trash-loc (loc &rest args)
(declare (ignore args))
@ -437,6 +434,31 @@
(wt-nl loc ";")
t))
(defun set-value0-loc (loc)
(wt-nl "value0 = " (coerce-loc :object loc) ";"))
(defun set-the-loc (loc type orig-loc)
(declare (ignore type))
(set-loc orig-loc loc))
(defun set-leave-loc (loc)
(cond ((or (eq loc 'VALUEZ) (uses-values loc))
(wt-nl "value0 = " (coerce-loc :object loc) ";"))
((eq loc 'VALUE0)
(wt-nl "cl_env_copy->nvalues = 1;"))
((eq loc 'LEAVE))
(t
(wt-nl "value0 = " (coerce-loc :object loc) ";")
(wt-nl "cl_env_copy->nvalues = 1;"))))
(defun set-valuez-loc (loc)
(cond ((eq loc 'VALUEZ))
((uses-values loc)
(wt-nl "cl_env_copy->values[0] = " (coerce-loc :object loc) ";"))
(t
(wt-nl "cl_env_copy->values[0] = " (coerce-loc :object loc) ";")
(wt-nl "cl_env_copy->nvalues = 1;"))))
;;;
;;; Foreign data
;;;

60
src/cmp/cmpbackend-cxx/cmppass2-top.lsp
View file

@ -35,14 +35,13 @@
(defun t2expr (form)
(check-type form c1form)
(ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*)))
(let ((*compile-file-truename* (c1form-file form))
(*compile-file-position* (c1form-file-position form))
(*current-toplevel-form* (c1form-form form))
(*current-form* (c1form-form form))
(*cmp-env* (c1form-env form)))
(apply def form (c1form-args form)))
(cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))
(with-c1form-env (form form)
(let* ((name (c1form-name form))
(args (c1form-args form))
(dispatch (gethash name *t2-dispatch-table*)))
(if dispatch
(apply dispatch form args)
(cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))))
(defun t2compiler-let (c1form symbols values body)
(declare (ignore c1form))
@ -271,7 +270,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 +283,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 ","))
@ -314,27 +313,26 @@
(when *compile-print*
(ext:when-let ((name (or (fun-name fun) (fun-description fun))))
(format t "~&;;; Emitting code for ~s.~%" name)))
(let* ((lambda-expr (fun-lambda fun))
(*cmp-env* (c1form-env lambda-expr))
(*tail-recursion-info* fun)
(*tail-recursion-mark* nil))
(with-bir-env (:env (fun-env fun)
:level (fun-lexical-levels fun)
:volatile (c1form-volatile* lambda-expr))
(t3function-declaration fun)
(wt-nl-open-brace)
(let ((body (t3function-body fun)))
(wt-function-locals (fun-closure fun))
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(when (eq (fun-closure fun) 'CLOSURE)
(wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
(wt-nl "cl_object " *volatile* "value0;")
(when (policy-check-stack-overflow)
(wt-nl "ecl_cs_check(cl_env_copy,value0);"))
(when (eq (fun-closure fun) 'CLOSURE)
(t3function-closure-scan fun))
(write-sequence body *compiler-output1*)
(wt-nl-close-many-braces 0)))))
(with-c1form-env (lambda-expr (fun-lambda fun))
(let ((*tail-recursion-info* fun)
(*tail-recursion-mark* nil))
(with-bir-env (:env (fun-env fun)
:level (fun-lexical-levels fun)
:volatile (c1form-volatile* lambda-expr))
(t3function-declaration fun)
(wt-nl-open-brace)
(let ((body (t3function-body fun)))
(wt-function-locals (fun-closure fun))
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(when (eq (fun-closure fun) 'CLOSURE)
(wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
(wt-nl "cl_object " *volatile* "value0;")
(when (policy-check-stack-overflow)
(wt-nl "ecl_cs_check(cl_env_copy,value0);"))
(when (eq (fun-closure fun) 'CLOSURE)
(t3function-closure-scan fun))
(write-sequence body *compiler-output1*)
(wt-nl-close-many-braces 0))))))
(defun t3function-body (fun)
(let ((string (make-array 2048 :element-type 'character

129
src/cmp/cmpbackend-cxx/cmppass2-var.lsp
View file

@ -12,13 +12,13 @@
(defun c2let-replaceable-var-ref-p (var form rest-forms)
(when (and (eq (c1form-name form) 'VARIABLE)
(null (var-set-nodes var))
(local var))
(local-var-p var))
(let ((var1 (c1form-arg 0 form)))
(declare (type var var1))
;; FIXME We should be able to replace variable even if they are referenced
;; across functions. We just need to keep track of their uses.
(when (and (local var1)
(eq (unboxed var) (unboxed var1))
(when (and (local-var-p var1)
(eq (unboxed-var-p var) (unboxed-var-p var1))
(not (var-changed-in-form-list var1 rest-forms)))
(cmpdebug "Replacing variable ~a by its value" (var-name var))
(nsubst-var var form)
@ -90,20 +90,20 @@
(*inline-blocks* 0))
;; Replace read-only variables when it is worth doing it.
(loop for var in vars
for rest-forms on (append forms (list body))
for form = (first rest-forms)
unless (c2let-replaceable-var-ref-p var form rest-forms)
collect var into used-vars and
collect form into used-forms
finally (setf vars used-vars forms used-forms))
for rest-forms on (append forms (list body))
for form = (first rest-forms)
unless (c2let-replaceable-var-ref-p var form rest-forms)
collect var into used-vars and
collect form into used-forms
finally (setf vars used-vars forms used-forms))
;; Emit C definitions of local variables
(loop for var in vars
for kind = (local var)
do (when kind
(maybe-open-inline-block)
(bind (next-lcl (var-name var)) var)
(wt-nl *volatile* (rep-type->c-name kind) " " var ";")))
for kind = (local-var-p var)
do (when kind
(maybe-open-inline-block)
(bind (next-lcl (var-name var)) var)
(wt-nl *volatile* (host-type->c-name kind) " " var ";")))
;; Create closure bindings for closed-over variables
(when (some #'var-ref-ccb vars)
@ -154,14 +154,14 @@
;; closure, make a local C variable.
(dolist (var vars)
(declare (type var var))
(let ((kind (local var)))
(if kind
(when (useful-var-p var)
(maybe-open-inline-block)
(bind (next-lcl) var)
(wt-nl (rep-type->c-name kind) " " *volatile* var ";")
(wt-comment (var-name var)))
(unless env-grows (setq env-grows (var-ref-ccb var))))))
(ext:if-let ((kind (local-var-p var)))
(when (useful-var-p var)
(maybe-open-inline-block)
(bind (next-lcl) 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.
(when (setq env-grows (env-grows env-grows))
(let ((env-lvl *env-lvl*))
@ -178,11 +178,11 @@
(close-inline-blocks)))
(defun c2location (c1form loc)
(unwind-exit (precise-loc-type loc (c1form-primary-type c1form))))
(unwind-exit (precise-loc-lisp-type loc (c1form-primary-type c1form))))
;;; When LOC is not NIL, then the variable is a constant.
(defun c2variable (c1form var loc)
(unwind-exit (precise-loc-type
(unwind-exit (precise-loc-lisp-type
(if (and loc (not (numberp (vv-location loc))))
loc
(or (try-const-c-inliner var) var))
@ -212,37 +212,24 @@
(wt-nl lcl " = ecl_progv(cl_env_copy, " sym-loc ", " val-loc ");")
(c2expr body)))))
(defun c2psetq (c1form vrefs forms
&aux (*lcl* *lcl*) (saves nil) (braces *opened-c-braces*))
(defun c2psetq (c1form vrefs forms &aux (saves nil))
(declare (ignore c1form))
;; similar to inline-args
(do ((vrefs vrefs (cdr vrefs))
(forms forms (cdr forms))
(var) (form))
((null vrefs))
(setq var (first vrefs)
form (car forms))
(if (or (var-changed-in-form-list var (rest forms))
(var-referenced-in-form-list var (rest forms)))
(case (c1form-name form)
(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)))
(wt-nl-open-brace)
(wt-nl rep-type-c-name " " *volatile* temp ";")
(let ((*destination* temp)) (c2expr* form))
(push (cons var temp) saves))
(let ((*destination* (make-temp-var)))
(c2expr* form)
(push (cons var *destination*) saves)))))
(let ((*destination* var))
(c2expr* form))))
(dolist (save saves)
(set-var (cdr save) (car save)))
(wt-nl-close-many-braces braces)
(with-inline-blocks ()
(loop for var in vrefs
for (form . rest-forms) on forms
do (if (or (var-changed-in-form-list var rest-forms)
(var-referenced-in-form-list var rest-forms))
(if (eq (c1form-name form) 'LOCATION)
(push (cons var (c1form-arg 0 form)) saves)
(let* ((typ (c1form-primary-type form))
(rep (var-host-type var))
(tmp (emit-inlined-temp-var form typ rep)))
(push (cons var tmp) saves)))
(let ((*destination* var))
(c2expr* form))))
(dolist (save saves)
(set-var (cdr save) (car save))))
(unwind-exit *vv-nil*))
;;; bind must be called for each variable in a lambda or let, once the value
@ -261,9 +248,8 @@
(setq var-loc (next-env))
(setf (var-loc var) var-loc))
(when (zerop var-loc) (wt-nl "env" *env-lvl* " = ECL_NIL;"))
(wt-nl "CLV" var-loc " = env" *env-lvl* " = CONS(")
(wt-coerce-loc :object loc)
(wt ",env" *env-lvl* ");")
(wt-nl "CLV" var-loc " = env" *env-lvl*
" = CONS(" (coerce-loc :object loc) ",env" *env-lvl* ");")
(wt-comment (var-name var))))
(LEXICAL
(let ((var-loc (var-loc var)))
@ -271,9 +257,7 @@
;; first binding: assign location
(setq var-loc (next-lex))
(setf (var-loc var) var-loc))
(wt-nl) (wt-lex var-loc) (wt " = ")
(wt-coerce-loc :object loc)
(wt ";"))
(wt-nl) (wt-lex var-loc) (wt " = " (coerce-loc :object loc) ";"))
(wt-comment (var-name var)))
((SPECIAL GLOBAL)
(bds-bind loc var))
@ -282,9 +266,7 @@
;; already has location (e.g. optional in lambda list)
;; check they are not the same
(unless (equal (var-loc var) loc)
(wt-nl var " = ")
(wt-coerce-loc (var-rep-type var) loc)
(wt ";")))
(wt-nl var " = " (coerce-loc (var-host-type var) loc) ";")))
((and (consp loc) (eql (car loc) 'LCL))
;; set location for lambda list requireds
(setf (var-loc var) loc))
@ -300,7 +282,7 @@
;; environments, global environments, etc. If we use `(BIND var)
;; as destination, BIND might receive the wrong environment.
(with-inline-blocks ()
(let ((locs (coerce-locs (inline-args (list form)))))
(let ((locs (coerce-args (inline-args (list form)))))
(bind (first locs) var)
;; Notice that we do not need to update *UNWIND-EXIT* because BIND
;; does it for us.
@ -316,9 +298,8 @@
(eq (var-name loc) (var-name var)))
(wt-nl "ecl_bds_push(cl_env_copy," (var-loc var) ");"))
(t
(wt-nl "ecl_bds_bind(cl_env_copy," (var-loc var) ",")
(wt-coerce-loc :object loc)
(wt ");")))
(wt-nl "ecl_bds_bind(cl_env_copy," (var-loc var) ","
(coerce-loc :object loc) ");")))
(push 'BDS-BIND *unwind-exit*)
(wt-comment (var-name var)))
@ -411,24 +392,16 @@
:format-arguments (list var)))
(case (var-kind var)
(CLOSURE
(wt-nl)(wt-env var-loc)(wt " = ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
(wt-nl)(wt-env var-loc)(wt " = " (coerce-loc (var-host-type var) loc) ";"))
(LEXICAL
(wt-nl)(wt-lex var-loc)(wt " = ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
(wt-nl)(wt-lex var-loc)(wt " = " (coerce-loc (var-host-type var) loc) ";"))
((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 ");"))
(wt (coerce-loc (var-host-type var) loc) ");"))
(t
(wt-nl var-loc " = ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
))
(wt-nl var-loc " = " (coerce-loc (var-host-type var) loc) ";"))))
(defun wt-lcl (lcl)
(unless (numberp lcl)

44
src/cmp/cmpform.lsp
View file

@ -60,22 +60,22 @@
(defun c1form-add-info-loop (form dependents)
(loop with subform
while (consp dependents)
when (c1form-p (setf subform (pop dependents)))
do (progn
(when (c1form-sp-change subform)
(setf (c1form-sp-change form) t
(c1form-side-effects form) t))
(when (c1form-side-effects subform)
(setf (c1form-side-effects form) t))
(unless (eq (c1form-name subform) 'LOCATION)
(when (rest (c1form-parents subform))
(error "Running twice through same form"))
(setf (c1form-parents subform)
(nconc (c1form-parents subform)
(c1form-parents form)))))
when (consp subform)
do (c1form-add-info-loop form subform)))
while (consp dependents)
when (c1form-p (setf subform (pop dependents)))
do (progn
(when (c1form-sp-change subform)
(setf (c1form-sp-change form) t
(c1form-side-effects form) t))
(when (c1form-side-effects subform)
(setf (c1form-side-effects form) t))
(unless (eq (c1form-name subform) 'LOCATION)
(when (rest (c1form-parents subform))
(error "Running twice through same form"))
(setf (c1form-parents subform)
(nconc (c1form-parents subform)
(c1form-parents form)))))
when (consp subform)
do (c1form-add-info-loop form subform)))
(defun c1form-add-info (form dependents)
(let ((record (gethash (c1form-name form) +c1-form-hash+)))
@ -137,6 +137,9 @@
do (traverse-c1form-tree f function))
(funcall function tree))))
(defun c1form-pure-p (form)
(third (gethash (c1form-name form) +c1-form-hash+)))
(defun c1form-movable-p (form)
(flet ((abort-on-not-pure (form)
(let ((name (c1form-name form)))
@ -146,20 +149,16 @@
(var-set-nodes var))
(return-from c1form-movable-p nil))))
((or (c1form-side-effects form)
(not (third (gethash name +c1-form-hash+))))
(not (c1form-pure-p form)))
(return-from c1form-movable-p nil))))))
(abort-on-not-pure form)))
(defun c1form-pure-p (form)
(third (gethash (c1form-name form) +c1-form-hash+)))
(defun c1form-unmodified-p (form rest-form)
(flet ((abort-on-not-pure (form)
(let ((name (c1form-name form)))
(cond ((eq name 'VARIABLE)
(let ((var (c1form-arg 0 form)))
(when (or (global-var-p var)
(var-changed-in-form-list var rest-form))
(when (var-changed-in-form-list var rest-form)
(return-from c1form-unmodified-p nil))))
((or (c1form-side-effects form)
(not (c1form-pure-p form)))
@ -178,6 +177,7 @@
(defmacro with-c1form-env ((form value) &rest body)
`(let* ((,form ,value)
(*current-c1form* ,form)
(*compile-file-truename* (c1form-file ,form))
(*compile-file-position* (c1form-file-position ,form))
(*current-toplevel-form* (c1form-toplevel-form ,form))

2
src/cmp/cmpglobals.lsp
View file

@ -24,11 +24,13 @@
;;; Variables and constants for error handling
;;;
(defvar *current-form* '|compiler preprocess|)
(defvar *current-c1form*)
(defvar *current-toplevel-form* '|compiler preprocess|)
(defvar *compile-file-position* -1)
(defvar *active-protection* nil)
(defvar *pending-actions* nil)
(defvar *empty-loc* (gensym))
(defvar *inline-loc* (gensym))
(defvar *compiler-conditions* '()
"This variable determines whether conditions are printed or just accumulated.")

133
src/cmp/cmplocs.lsp
View file

@ -23,21 +23,76 @@
;;; second pass the backend decides if the referenced object can be inlined, or
;;; if it needs to be put in the data segment and initialized at load-time.
(defstruct vv
(defstruct (vv (:constructor %make-vv))
(location nil)
(used-p nil)
(always nil) ; when true then vv is never optimized
(permanent-p t)
(value nil)
(rep-type :object))
(type nil)
(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.
(defun vv-type (loc)
(let ((value (vv-value loc)))
(if (eq value *empty-loc*)
t
(type-of value))))
(defun make-vv (&rest args &key location used-p always permanent-p value type host-type)
(declare (ignore location used-p always permanent-p host-type))
(unless type
;; 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.
(setf type (if (eq value *empty-loc*) t (type-of value))))
(apply #'%make-vv :type type args))
;;; TODO investigate where raw numbers are stemming from and change them to VV
;;; TODO tighter checks for compound locations (cons)
;;; TODO baboon on locations that are unknown (for now we signal a warning)
;;;
;;; -- jd 2023-12-07
(defun loc-lisp-type (loc)
(typecase loc
(var (var-type loc))
(vv (vv-type loc))
(number (type-of loc))
(atom
(case loc
(FRAME++ 'FIXNUM)
((TRASH LEAVE VALUE0 VA-ARG VALUEZ CL-VA-ARG) T)
(otherwise
(cmpwarn "LOC-LISP-TYPE: unknown location ~s." loc)
T)))
(otherwise
(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 (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-host-type (loc)
(typecase loc
(var (var-host-type loc))
(vv (vv-host-type loc))
(number (lisp-type->host-type (type-of loc)))
(atom
(case loc
(TRASH :void)
((FRAME++ LEAVE VALUE0 VA-ARG VALUEZ CL-VA-ARG) :object)
(otherwise
(cmpwarn "LOC-LISP-TYPE: unknown location ~s." loc)
:object)))
(otherwise
(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->host-type type))
(t type))))
(BIND (var-host-type (second loc)))
(LCL (lisp-type->host-type (or (third loc) T)))
((JUMP-TRUE JUMP-FALSE) :bool)
(THE (loc-host-type (third loc)))
(otherwise :object)))))
(defun loc-movable-p (loc)
(if (atom loc)
@ -47,43 +102,6 @@
((ffi:c-inline) (not (fifth loc))) ; side effects?
(otherwise t))))
(defun loc-type (loc)
(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)))
((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)))))
(BIND (var-type (second loc)))
(LCL (or (third loc) T))
(THE (second loc))
(CALL-NORMAL (fourth loc))
(otherwise T)))))
(defun loc-representation-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)))
((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))
(t type))))
(BIND (var-rep-type (second loc)))
(LCL (lisp-type->rep-type (or (third loc) T)))
((JUMP-TRUE JUMP-FALSE) :bool)
(THE (loc-representation-type (third loc)))
(otherwise :object)))))
(defun loc-with-side-effects-p (loc &aux name)
(when (atom loc)
(return-from loc-with-side-effects-p
@ -119,14 +137,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
@ -136,10 +154,11 @@
;;; VA-ARG
;;; CL-VA-ARG
(defun precise-loc-type (loc new-type)
(if (subtypep (loc-type loc) new-type)
loc
`(the ,new-type ,loc)))
(defun precise-loc-lisp-type (loc new-type)
(let ((loc-type (loc-lisp-type loc)))
(if (subtypep loc-type new-type)
loc
`(the ,(type-and loc-type new-type) ,loc))))
(defun loc-in-c1form-movable-p (loc)
"A location that is in a C1FORM and can be moved"
@ -174,9 +193,13 @@
(values t loc))
((vv-p loc)
(let ((value (vv-value loc)))
(if (eq value *empty-loc*)
(values nil nil)
(values t value))))
(cond
((eq value *empty-loc*)
(values nil nil))
((eq value *inline-loc*)
(loc-immediate-value-p (vv-location loc)))
(t
(values t value)))))
((atom loc)
(values nil nil))
((eq (first loc) 'THE)

16
src/cmp/cmppass1-ffi.lsp
View file

@ -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)))

2
src/cmp/cmppass1-var.lsp
View file

@ -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"

4
src/cmp/cmpprop.lsp
View file

@ -53,8 +53,8 @@
(defun p1var (form var loc)
;; Use the type of C1FORM because it might have been coerced by a THE form.
(let* ((loc-type (if loc (object-type (vv-value loc)) t))
(var-type (var-type var))
(let* ((loc-type (if loc (loc-lisp-type loc) t))
(var-type (loc-lisp-type var))
(type (type-and (type-and loc-type var-type)
(c1form-primary-type form))))
(prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type)

7
src/cmp/cmptables.lsp
View file

@ -35,9 +35,6 @@
;; Function namespace (should include also FSET)
(CL:FUNCTION fname :single-valued)
(LOCALS local-fun-list body labels-p :pure)
;; Specialized accessors
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
(SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects)
;; Control structures
(CL:BLOCK blk-var progn-c1form :pure)
(CL:RETURN-FROM blk-var nonlocal value :side-effects)
@ -63,7 +60,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))))
@ -180,9 +177,9 @@
(cl:fdefinition . wt-fdefinition)
(make-cclosure . wt-make-closure)
(si:structure-ref . wt-structure-ref)
(ffi-data-ref . wt-ffi-data-ref)
(frame++ . "ECL_NEW_FRAME_ID(cl_env_copy)")
(leave . "value0")
(va-arg . "va_arg(args,cl_object)")
(cl-va-arg . "ecl_va_arg(args)")

18
src/cmp/cmpvar.lsp
View file

@ -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,13 +179,13 @@
;; 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)))
(defun unboxed-var-p (var)
(not (eq (var-host-type var) :object)))
(defun local (var)
(defun local-var-p (var)
(and (not (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL)))
(var-kind var)))