From 2c09a82c1126818edce8db2d4dac97d831dc7347 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 17 Feb 2023 13:30:21 +0100 Subject: [PATCH] cmp: move locations and representations into separate files --- src/cmp/cmplocs.lsp | 249 ++++++++++++++++++++++ src/cmp/{cmpc-machine.lsp => cmpmach.lsp} | 73 +++++-- src/cmp/cmppass2-call.lsp | 5 + src/cmp/cmppass2-data.lsp | 5 - src/cmp/cmppass2-exit.lsp | 4 +- src/cmp/cmppass2-ffi.lsp | 104 --------- src/cmp/cmppass2-loc.lsp | 165 -------------- src/cmp/cmppass2-var.lsp | 4 +- src/cmp/cmptypes.lsp | 24 --- src/cmp/load.lsp.in | 4 +- 10 files changed, 321 insertions(+), 316 deletions(-) create mode 100644 src/cmp/cmplocs.lsp rename src/cmp/{cmpc-machine.lsp => cmpmach.lsp} (85%) diff --git a/src/cmp/cmplocs.lsp b/src/cmp/cmplocs.lsp new file mode 100644 index 000000000..3071c44de --- /dev/null +++ b/src/cmp/cmplocs.lsp @@ -0,0 +1,249 @@ + +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański +;;;; +;;;; See file 'LICENSE' for the copyright details. + +(in-package #:compiler) + +;;; ---------------------------------------------------------------------------- +;;; LOCATIONS and representation types +;;; +;;; Locations are lisp expressions which represent actual target (i.e C) data. +;;; To each location we can associate a representation type, which is the type +;;; of the target data (i.e uint32_t). + +;;; The following routines help in determining these types, and also in moving +;;; data from one location to another. + +(defstruct vv + (location nil) + (used-p nil) + (permanent-p t) + (value nil)) + +(defun vv-type (loc) + (let ((value (vv-value loc))) + (if (and value (not (ext:fixnump value))) + (type-of value) + t))) + +(defun loc-movable-p (loc) + (if (atom loc) + t + (case (first loc) + ((CALL CALL-LOCAL) NIL) + ((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) + (FIXNUM-VALUE 'FIXNUM) + (CHARACTER-VALUE (type-of (code-char (second loc)))) + (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) + (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) + (LONG-FLOAT-VALUE 'LONG-FLOAT) + (CSFLOAT-VALUE 'SI:COMPLEX-SINGLE-FLOAT) + (CDFLOAT-VALUE 'SI:COMPLEX-DOUBLE-FLOAT) + (CLFLOAT-VALUE 'SI:COMPLEX-LONG-FLOAT) + (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) :object) + ((numberp loc) (lisp-type->rep-type (type-of loc))) + ((eq loc 'TRASH) :void) + ((atom loc) :object) + (t + (case (first loc) + (FIXNUM-VALUE :fixnum) + (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) + (DOUBLE-FLOAT-VALUE :double) + (SINGLE-FLOAT-VALUE :float) + (LONG-FLOAT-VALUE :long-double) + (CSFLOAT-VALUE :csfloat) + (CDFLOAT-VALUE :cdfloat) + (CLFLOAT-VALUE :clfloat) + (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) + (cond ((var-p loc) + (and (global-var-p loc) + (policy-global-var-checking))) + ((atom loc) + nil) + ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT) + :test #'eq) + t) + ((eq name 'cl:THE) + (loc-with-side-effects-p (third loc))) + ((eq name 'cl:FDEFINITION) + (policy-global-function-checking)) + ((eq name 'ffi:C-INLINE) + (or (eq (sixth loc) 'cl:VALUES) ;; Uses VALUES + (fifth loc))))) ;; or side effects + +(defun loc-refers-to-special-p (loc) + (cond ((var-p loc) + (member (var-kind loc) '(SPECIAL GLOBAL))) + ((atom loc) + nil) + ((eq (first loc) 'THE) + (loc-refers-to-special-p (third loc))) + ((eq (setf loc (first loc)) 'BIND) + t) + ((eq loc 'ffi:C-INLINE) + t) ; We do not know, so guess yes + (t nil))) + +;;; Valid locations are: +;;; NIL +;;; T +;;; fixnum +;;; VALUE0 +;;; VALUES +;;; var-object +;;; a string designating a C expression +;;; ( VALUE i ) VALUES(i) +;;; ( VV vv-index ) +;;; ( VV-temp vv-index ) +;;; ( LCL lcl [representation-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 +;;; ( FFI:C-INLINE output-type fun/string locs side-effects output-var ) +;;; ( COERCE-LOC representation-type location) +;;; ( FDEFINITION vv-index ) +;;; ( MAKE-CCLOSURE cfun ) +;;; ( FIXNUM-VALUE fixnum-value ) +;;; ( CHARACTER-VALUE character-code ) +;;; ( LONG-FLOAT-VALUE long-float-value vv ) +;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) +;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) +;;; ( CSFLOAT-VALUE csfloat-value vv ) +;;; ( CDFLOAT-VALUE cdfloat-value vv ) +;;; ( CLFLOAT-VALUE clfloat-value vv ) +;;; ( STACK-POINTER index ) retrieve a value from the stack +;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) +;;; ( THE type location ) +;;; ( KEYVARS n ) +;;; VA-ARG +;;; CL-VA-ARG + +;;; Valid *DESTINATION* locations are: +;;; +;;; VALUE0 +;;; RETURN Object returned from current function. +;;; TRASH Value may be thrown away. +;;; VALUES Values vector. +;;; var-object +;;; ( LCL lcl ) +;;; ( LEX lex-address ) +;;; ( BIND var alternative ) Alternative is optional +;;; ( JUMP-TRUE label ) +;;; ( JUMP-FALSE label ) + +(defun tmp-destination (loc) + (case loc + (VALUES 'VALUES) + (TRASH 'TRASH) + (T 'RETURN))) + +(defun precise-loc-type (loc new-type) + (if (subtypep (loc-type loc) new-type) + loc + `(the ,new-type ,loc))) + +(defun loc-in-c1form-movable-p (loc) + "A location that is in a C1FORM and can be moved" + (cond ((member loc '(t nil)) + t) + ((numberp loc) + t) + ((stringp loc) + t) + ((vv-p loc) + t) + ((member loc '(value0 values va-arg cl-va-arg)) + nil) + ((atom loc) + (baboon :format-control "Unknown location ~A found in C1FORM" + :format-arguments (list loc))) + ((eq (first loc) 'THE) + (loc-in-c1form-movable-p (third loc))) + ((member (setf loc (car loc)) + '(VV VV-TEMP FIXNUM-VALUE CHARACTER-VALUE + DOUBLE-FLOAT-VALUE SINGLE-FLOAT-VALUE LONG-FLOAT-VALUE + #+complex-float CSFLOAT-VALUE + #+complex-float CDFLOAT-VALUE + #+complex-float CLFLOAT-VALUE + KEYVARS)) + t) + (t + (baboon :format-control "Unknown location ~A found in C1FORM" + :format-arguments (list loc))))) + +(defun uses-values (loc) + (and (consp loc) + (or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT) :test #'eq) + (and (eq (car loc) 'ffi:C-INLINE) + (eq (sixth loc) 'cl:VALUES))))) + +(defun loc-immediate-value-p (loc) + (cond ((eq loc t) + (values t t)) + ((eq loc nil) + (values t nil)) + ((numberp loc) + (values t loc)) + ((vv-p loc) + (let ((value (vv-value loc))) + (if (or (null value) (ext:fixnump value)) + (values nil nil) + (values t value)))) + ((atom loc) + (values nil nil)) + ((eq (first loc) 'THE) + (loc-immediate-value-p (third loc))) + ((member (first loc) + '(fixnum-value long-float-value + double-float-value single-float-value + csfloat-value cdfloat-value clfloat-value)) + (values t (second loc))) + ((eq (first loc) 'character-value) + (values t (code-char (second loc)))) + (t + (values nil nil)))) + +(defun loc-immediate-value (loc) + (nth-value 1 (loc-immediate-value-p loc))) + +(defun unknown-location (where loc) + (baboon :format-control "Unknown location found in ~A~%~S" + :format-arguments (list where loc))) diff --git a/src/cmp/cmpc-machine.lsp b/src/cmp/cmpmach.lsp similarity index 85% rename from src/cmp/cmpc-machine.lsp rename to src/cmp/cmpmach.lsp index eff6d6fb2..1ccb8c698 100644 --- a/src/cmp/cmpc-machine.lsp +++ b/src/cmp/cmpmach.lsp @@ -1,20 +1,65 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*- -;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab: +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya +;;;; Copyright (c) 1990, Giuseppe Attardi +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; Copyright (c) 2023, Daniel Kochmański ;;;; -;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll. -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. -;;;; -;;;; CMPC-MACHINE -- Abstract target machine details -;;;; +;;;; See file 'LICENSE' for the copyright details. -(in-package "COMPILER") +(in-package #:compiler) + +;;; Abstract target machine details + +(defstruct machine + (c-types '()) + rep-type-hash + sorted-types + inline-information) + +;;; FIXME currently all definitions assume C machine (see cmpc-machine.lsp). + +(defstruct (rep-type (:constructor %make-rep-type)) + (index 0) ; Precedence order in the type list + (name t) + (lisp-type t) + (bits nil) + (numberp nil) + (integerp nil) + (c-name nil) + (to-lisp nil) + (from-lisp nil) + (from-lisp-unsafe nil)) + +(defun lisp-type-p (type) + (subtypep type 'T)) + +(defun rep-type-record-unsafe (rep-type) + (gethash rep-type (machine-rep-type-hash *machine*))) + +(defun rep-type-record (rep-type) + (ext:if-let ((record (gethash rep-type (machine-rep-type-hash *machine*)))) + record + (cmperr "Not a valid C type name ~A" rep-type))) + +(defun rep-type->lisp-type (name) + (let ((output (rep-type-record-unsafe name))) + (cond (output + (rep-type-lisp-type output)) + ((lisp-type-p name) name) + (t (error "Unknown representation type ~S" name))))) + +(defun lisp-type->rep-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)))) + (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))))))) ;; 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 diff --git a/src/cmp/cmppass2-call.lsp b/src/cmp/cmppass2-call.lsp index 6b98066a9..34b4cd8a4 100644 --- a/src/cmp/cmppass2-call.lsp +++ b/src/cmp/cmppass2-call.lsp @@ -78,6 +78,11 @@ ((or (consp ue) (eq ue 'JUMP) (eq ue 'IHS-ENV))) (t (baboon :format-control "tail-recursion-possible: unexpected situation."))))) +(defun last-call-p () + (member *exit* + '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SINGLE-FLOAT + RETURN-DOUBLE-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT))) + (defun c2try-tail-recursive-call (fun args) (when (and *tail-recursion-info* (eq fun (first *tail-recursion-info*)) diff --git a/src/cmp/cmppass2-data.lsp b/src/cmp/cmppass2-data.lsp index 776b9dd01..4d518a1b2 100644 --- a/src/cmp/cmppass2-data.lsp +++ b/src/cmp/cmppass2-data.lsp @@ -252,8 +252,3 @@ (setf (vv-used-p vv-loc) t) (set-vv-index loc (vv-location vv-loc) (vv-permanent-p vv-loc))) -(defun vv-type (loc) - (let ((value (vv-value loc))) - (if (and value (not (ext:fixnump value))) - (type-of value) - t))) diff --git a/src/cmp/cmppass2-exit.lsp b/src/cmp/cmppass2-exit.lsp index ebb06ad29..5217d377b 100644 --- a/src/cmp/cmppass2-exit.lsp +++ b/src/cmp/cmppass2-exit.lsp @@ -89,8 +89,8 @@ (set-loc loc)) ;; Save the value if LOC may possibly refer ;; to special binding. - ((or (loc-refers-to-special loc) - (loc-refers-to-special *destination*)) + ((or (loc-refers-to-special-p loc) + (loc-refers-to-special-p *destination*)) (let* ((*temp* *temp*) (temp (make-temp-var))) (let ((*destination* temp)) diff --git a/src/cmp/cmppass2-ffi.lsp b/src/cmp/cmppass2-ffi.lsp index bb21e2f54..bc36c7140 100644 --- a/src/cmp/cmppass2-ffi.lsp +++ b/src/cmp/cmppass2-ffi.lsp @@ -15,38 +15,6 @@ (in-package "COMPILER") -;; ---------------------------------------------------------------------- -;; REPRESENTATION TYPES -;; - -(defun rep-type-record-unsafe (rep-type) - (gethash rep-type (machine-rep-type-hash *machine*))) - -(defun rep-type-record (rep-type) - (ext:if-let ((record (gethash rep-type (machine-rep-type-hash *machine*)))) - record - (cmperr "Not a valid C type name ~A" rep-type))) - -(defun rep-type->lisp-type (name) - (let ((output (rep-type-record-unsafe name))) - (cond (output - (rep-type-lisp-type output)) - ((lisp-type-p name) name) - (t (error "Unknown representation type ~S" name))))) - -(defun lisp-type->rep-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)))) - (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))))))) - (defun c-number-rep-type-p (rep-type) (let ((r (rep-type-record-unsafe rep-type))) (and r (rep-type-numberp r)))) @@ -71,9 +39,6 @@ (defun rep-type->c-name (type) (rep-type-c-name (rep-type-record type))) -(defun lisp-type-p (type) - (subtypep type 'T)) - (defun wt-to-object-conversion (loc-rep-type loc) (when (and (consp loc) (member (first loc) '(single-float-value @@ -100,75 +65,6 @@ coercer) "(" loc ")"))) -;; ---------------------------------------------------------------------- -;; LOCATIONS and representation types -;; -;; Locations are lisp expressions which represent actual C data. To each -;; location we can associate a representation type, which is the type of -;; the C data. The following routines help in determining these types, -;; and also in moving data from one location to another. - -(defun loc-movable-p (loc) - (if (atom loc) - t - (case (first loc) - ((CALL CALL-LOCAL) NIL) - ((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) - (FIXNUM-VALUE 'FIXNUM) - (CHARACTER-VALUE (type-of (code-char (second loc)))) - (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT) - (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT) - (LONG-FLOAT-VALUE 'LONG-FLOAT) - (CSFLOAT-VALUE 'SI:COMPLEX-SINGLE-FLOAT) - (CDFLOAT-VALUE 'SI:COMPLEX-DOUBLE-FLOAT) - (CLFLOAT-VALUE 'SI:COMPLEX-LONG-FLOAT) - (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) :object) - ((numberp loc) (lisp-type->rep-type (type-of loc))) - ((eq loc 'TRASH) :void) - ((atom loc) :object) - (t - (case (first loc) - (FIXNUM-VALUE :fixnum) - (CHARACTER-VALUE (if (<= (second loc) 255) :unsigned-char :wchar)) - (DOUBLE-FLOAT-VALUE :double) - (SINGLE-FLOAT-VALUE :float) - (LONG-FLOAT-VALUE :long-double) - (CSFLOAT-VALUE :csfloat) - (CDFLOAT-VALUE :cdfloat) - (CLFLOAT-VALUE :clfloat) - (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 wt-coerce-loc (dest-rep-type loc) (setq dest-rep-type (lisp-type->rep-type dest-rep-type)) ;(print dest-rep-type) diff --git a/src/cmp/cmppass2-loc.lsp b/src/cmp/cmppass2-loc.lsp index 2f6d134f1..14525bc63 100644 --- a/src/cmp/cmppass2-loc.lsp +++ b/src/cmp/cmppass2-loc.lsp @@ -16,133 +16,6 @@ (in-package "COMPILER") -;;; Valid locations are: -;;; NIL -;;; T -;;; fixnum -;;; VALUE0 -;;; VALUES -;;; var-object -;;; a string designating a C expression -;;; ( VALUE i ) VALUES(i) -;;; ( VV vv-index ) -;;; ( VV-temp vv-index ) -;;; ( LCL lcl [representation-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 -;;; ( FFI:C-INLINE output-type fun/string locs side-effects output-var ) -;;; ( COERCE-LOC representation-type location) -;;; ( FDEFINITION vv-index ) -;;; ( MAKE-CCLOSURE cfun ) -;;; ( FIXNUM-VALUE fixnum-value ) -;;; ( CHARACTER-VALUE character-code ) -;;; ( LONG-FLOAT-VALUE long-float-value vv ) -;;; ( DOUBLE-FLOAT-VALUE double-float-value vv ) -;;; ( SINGLE-FLOAT-VALUE single-float-value vv ) -;;; ( CSFLOAT-VALUE csfloat-value vv ) -;;; ( CDFLOAT-VALUE cdfloat-value vv ) -;;; ( CLFLOAT-VALUE clfloat-value vv ) -;;; ( STACK-POINTER index ) retrieve a value from the stack -;;; ( SYS:STRUCTURE-REF loc slot-name-vv slot-index ) -;;; ( THE type location ) -;;; ( KEYVARS n ) -;;; VA-ARG -;;; CL-VA-ARG - -;;; Valid *DESTINATION* locations are: -;;; -;;; VALUE0 -;;; RETURN Object returned from current function. -;;; TRASH Value may be thrown away. -;;; VALUES Values vector. -;;; var-object -;;; ( LCL lcl ) -;;; ( LEX lex-address ) -;;; ( BIND var alternative ) Alternative is optional -;;; ( JUMP-TRUE label ) -;;; ( JUMP-FALSE label ) - -(defun tmp-destination (loc) - (case loc - (VALUES 'VALUES) - (TRASH 'TRASH) - (T 'RETURN))) - -(defun precise-loc-type (loc new-type) - (if (subtypep (loc-type loc) new-type) - loc - `(the ,new-type ,loc))) - -(defun loc-in-c1form-movable-p (loc) - "A location that is in a C1FORM and can be moved" - (cond ((member loc '(t nil)) - t) - ((numberp loc) - t) - ((stringp loc) - t) - ((vv-p loc) - t) - ((member loc '(value0 values va-arg cl-va-arg)) - nil) - ((atom loc) - (baboon :format-control "Unknown location ~A found in C1FORM" - :format-arguments (list loc))) - ((eq (first loc) 'THE) - (loc-in-c1form-movable-p (third loc))) - ((member (setf loc (car loc)) - '(VV VV-TEMP FIXNUM-VALUE CHARACTER-VALUE - DOUBLE-FLOAT-VALUE SINGLE-FLOAT-VALUE LONG-FLOAT-VALUE - #+complex-float CSFLOAT-VALUE - #+complex-float CDFLOAT-VALUE - #+complex-float CLFLOAT-VALUE - KEYVARS)) - t) - (t - (baboon :format-control "Unknown location ~A found in C1FORM" - :format-arguments (list loc))))) - -(defun uses-values (loc) - (and (consp loc) - (or (member (car loc) '(CALL CALL-NORMAL CALL-INDIRECT) :test #'eq) - (and (eq (car loc) 'ffi:C-INLINE) - (eq (sixth loc) 'cl:VALUES))))) - -(defun loc-immediate-value-p (loc) - (cond ((eq loc t) - (values t t)) - ((eq loc nil) - (values t nil)) - ((numberp loc) - (values t loc)) - ((vv-p loc) - (let ((value (vv-value loc))) - (if (or (null value) (ext:fixnump value)) - (values nil nil) - (values t value)))) - ((atom loc) - (values nil nil)) - ((eq (first loc) 'THE) - (loc-immediate-value-p (third loc))) - ((member (first loc) - '(fixnum-value long-float-value - double-float-value single-float-value - csfloat-value cdfloat-value clfloat-value)) - (values t (second loc))) - ((eq (first loc) 'character-value) - (values t (code-char (second loc)))) - (t - (values nil nil)))) - -(defun loc-immediate-value (loc) - (nth-value 1 (loc-immediate-value-p loc))) - -(defun unknown-location (where loc) - (baboon :format-control "Unknown location found in ~A~%~S" - :format-arguments (list where loc))) - (defun wt-loc (loc) (cond ((consp loc) (let ((fd (gethash (car loc) *wt-loc-dispatch-table*))) @@ -163,11 +36,6 @@ (t (unknown-location 'wt-loc loc)))) -(defun last-call-p () - (member *exit* - '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SINGLE-FLOAT - RETURN-DOUBLE-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT))) - (defun wt-lcl (lcl) (unless (numberp lcl) (baboon :format-control "wt-lcl: ~s NaN" :format-arguments (list lcl))) @@ -219,22 +87,6 @@ (declare (ignore type)) (wt-loc loc)) -(defun loc-refers-to-special (loc) - (cond ((var-p loc) - (member (var-kind loc) '(SPECIAL GLOBAL))) - ((atom loc) - nil) - ((eq (first loc) 'THE) - (loc-refers-to-special (third loc))) - ((eq (setf loc (first loc)) 'BIND) - t) - ((eq loc 'ffi:C-INLINE) - t) ; We do not know, so guess yes - (t nil))) - -(defun values-loc (n) - (list 'VALUE n)) - ;;; ;;; SET-LOC ;;; @@ -292,23 +144,6 @@ (wt-nl "value0 = ") (wt-coerce-loc :object loc) (wt ";") (wt-nl "cl_env_copy->nvalues = 1;")))) -(defun loc-with-side-effects-p (loc &aux name) - (cond ((var-p loc) - (and (global-var-p loc) - (policy-global-var-checking))) - ((atom loc) - nil) - ((member (setf name (first loc)) '(CALL CALL-NORMAL CALL-INDIRECT) - :test #'eq) - t) - ((eq name 'cl:THE) - (loc-with-side-effects-p (third loc))) - ((eq name 'cl:FDEFINITION) - (policy-global-function-checking)) - ((eq name 'ffi:C-INLINE) - (or (eq (sixth loc) 'cl:VALUES) ;; Uses VALUES - (fifth loc))))) ;; or side effects - (defun set-trash-loc (loc) (when (loc-with-side-effects-p loc) (wt-nl loc ";") diff --git a/src/cmp/cmppass2-var.lsp b/src/cmp/cmppass2-var.lsp index 67416d224..ae1ec2e09 100644 --- a/src/cmp/cmppass2-var.lsp +++ b/src/cmp/cmppass2-var.lsp @@ -282,7 +282,9 @@ (defun values-loc-or-value0 (i) (declare (si::c-local)) - (if (plusp i) (values-loc i) 'VALUE0)) + (if (plusp i) + (list 'VALUE i) + 'VALUE0)) (defun do-m-v-setq (vars form use-bind) ;; This routine moves values from the multiple-value stack into the diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index f225dc046..ba3e1d742 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -210,27 +210,3 @@ (toplevel-form nil) (file nil) (file-position 0)) - -(defstruct vv - (location nil) - (used-p nil) - (permanent-p t) - (value nil)) - -(defstruct machine - (c-types '()) - rep-type-hash - sorted-types - inline-information) - -(defstruct (rep-type (:constructor %make-rep-type)) - (index 0) ; Precedence order in the type list - (name t) - (lisp-type t) - (bits nil) - (numberp nil) - (integerp nil) - (c-name nil) - (to-lisp nil) - (from-lisp nil) - (from-lisp-unsafe nil)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index a65775c75..8360567bb 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -7,6 +7,9 @@ "build:cmp;cmpdefs.lsp" "src:cmp;cmputil.lsp" "src:cmp;cmpcond.lsp" + ;; Internal representation + "src:cmp;cmpmach.lsp" + "src:cmp;cmplocs.lsp" ;; Environment "src:cmp;cmpenv-api.lsp" "src:cmp;cmpenv-var.lsp" @@ -28,7 +31,6 @@ "src:cmp;cmptype.lsp" "src:cmp;cmptype-assert.lsp" ;; Abstract C machine - "src:cmp;cmpc-machine.lsp" "src:cmp;cmpc-wt.lsp" "src:cmp;cmpc-inliner.lsp" ;; AST building pass