diff --git a/src/cmp/cmpbackend-cxx/cmpc-arg-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-arg-inl.lsp index 6ca478510..1354e3884 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-arg-inl.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-arg-inl.lsp @@ -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)) diff --git a/src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp b/src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp index 632d2f7f0..d63df6711 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp @@ -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*))))))) diff --git a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp index 831e43985..045cb3de4 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp @@ -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 diff --git a/src/cmp/cmpbackend-cxx/cmpc-mach.lsp b/src/cmp/cmpbackend-cxx/cmpc-mach.lsp index c10273eb9..abdd87ef3 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-mach.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-mach.lsp @@ -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))) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp index 8b14750a0..6516c7c40 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp @@ -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))))) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp index fbcb8d7b7..38bf77d1d 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-num.lsp @@ -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) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp index b68d56040..5f75d819b 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp @@ -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) diff --git a/src/cmp/cmpbackend-cxx/cmpc-util.lsp b/src/cmp/cmpbackend-cxx/cmpc-util.lsp index b1a1b3c4b..16780fc56 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-util.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-util.lsp @@ -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))) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp index 6bbf24de9..3e0e2674c 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-call.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-call.lsp @@ -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)) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index 22ad17d0c..f652e7058 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -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) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-data.lsp b/src/cmp/cmpbackend-cxx/cmppass2-data.lsp index c66838d59..df5ce4385 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-data.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-data.lsp @@ -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) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp index ab166ce36..391a73310 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp @@ -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 ";") diff --git a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp index e3957d497..03397108c 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-exit.lsp @@ -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) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp index 0bb04d3d0..5b0aa3977 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-fun.lsp @@ -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) diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp index 7f0f85913..64846c8aa 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp @@ -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 ;;; diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp index 7e1cb4d1b..f61666228 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp @@ -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 diff --git a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp index 6f7621522..b27d9b359 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-var.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-var.lsp @@ -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) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index 613215e17..49281d071 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -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)) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index f62e95c79..de1a0f49b 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -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.") diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp index 2a4213f40..8bba6ceff 100644 --- a/src/cmp/cmplocs.lsp +++ b/src/cmp/cmplocs.lsp @@ -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) diff --git a/src/cmp/cmppass1-ffi.lsp b/src/cmp/cmppass1-ffi.lsp index 6eb22df4e..84be2eeef 100644 --- a/src/cmp/cmppass1-ffi.lsp +++ b/src/cmp/cmppass1-ffi.lsp @@ -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))) diff --git a/src/cmp/cmppass1-var.lsp b/src/cmp/cmppass1-var.lsp index 7871fcf05..225e5a621 100644 --- a/src/cmp/cmppass1-var.lsp +++ b/src/cmp/cmppass1-var.lsp @@ -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" diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 56bb324e0..b042eb091 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -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) diff --git a/src/cmp/cmptables.lsp b/src/cmp/cmptables.lsp index b9e904b13..e0c7d7b65 100644 --- a/src/cmp/cmptables.lsp +++ b/src/cmp/cmptables.lsp @@ -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)") diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index c51d4f15a..076940baa 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -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)))