mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-13 08:20:31 -07:00
cmp: move locations and representations into separate files
This commit is contained in:
Daniel Kochmański
parent
76f0ac2399
commit
2c09a82c11
10 changed files with 321 additions and 316 deletions
249
src/cmp/cmplocs.lsp
Normal file
249
src/cmp/cmplocs.lsp
Normal file
|
|
@ -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)))
|
||||
|
|
@ -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
|
||||
|
|
@ -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*))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 ";")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue